Merging in the new codegen branch

This merge does not turn on the new codegen (which only compiles
a select few programs at this point),
but it does introduce some changes to the old code generator.

The high bits:
1. The Rep Swamp patch is finally here.
   The highlight is that the representation of types at the
   machine level has changed.
   Consequently, this patch contains updates across several back ends.
2. The new Stg -> Cmm path is here, although it appears to have a
   fair number of bugs lurking.
3. Many improvements along the CmmCPSZ path, including:
   o stack layout
   o some code for infotables, half of which is right and half wrong
   o proc-point splitting

1 files changed, 316 insertions, 0 deletions

diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
new file mode 100644
index 0000000000..2d5d79e6ff
--- /dev/null
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -0,0 +1,316 @@
+{-# OPTIONS -w #-}
+-- Lots of missing type sigs etc
+
+-----------------------------------------------------------------------------
+--
+-- Code generation for foreign calls.
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmForeign (
+  cgForeignCall,
+  emitPrimCall, emitCCall,
+  emitSaveThreadState, -- will be needed by the Cmm parser
+  emitLoadThreadState, -- ditto
+  emitCloseNursery,
+  emitOpenNursery,
+ ) where
+
+#include "HsVersions.h"
+
+import StgSyn
+import StgCmmProf
+import StgCmmEnv
+import StgCmmMonad
+import StgCmmUtils
+import StgCmmClosure
+
+import MkZipCfgCmm
+import Cmm
+import CmmUtils
+import Type
+import TysPrim
+import CLabel
+import SMRep
+import ForeignCall
+import Constants
+import StaticFlags
+import Maybes
+import Outputable
+
+import Control.Monad
+
+-----------------------------------------------------------------------------
+-- Code generation for Foreign Calls
+-----------------------------------------------------------------------------
+
+cgForeignCall :: [LocalReg]		-- r1,r2  where to put the results
+	      -> [ForeignHint]
+	      -> ForeignCall		-- the op
+	      -> [StgArg]		-- x,y	  arguments
+	      -> FCode ()
+-- Emits code for an unsafe foreign call:      r1, r2 = foo( x, y, z )
+
+cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args
+  = do	{ cmm_args <- getFCallArgs stg_args
+	; let (args, arg_hints) = unzip cmm_args
+	      fc = ForeignConvention cconv arg_hints result_hints
+	      (call_args, cmm_target)
+		= case target of
+		   StaticTarget lbl -> (args, CmmLit (CmmLabel 
+						(mkForeignLabel lbl (call_size args) False)))
+		   DynamicTarget    ->  case args of fn:rest -> (rest, fn)
+	      call_target = ForeignTarget cmm_target fc
+	
+	; srt <- getSRTInfo (panic "emitForeignCall")	-- SLPJ: Not sure what SRT 
+							-- is right here
+	; emitForeignCall safety results call_target call_args srt CmmMayReturn }
+  where
+	-- in the stdcall calling convention, the symbol needs @size appended
+	-- to it, where size is the total number of bytes of arguments.  We
+	-- attach this info to the CLabel here, and the CLabel pretty printer
+	-- will generate the suffix when the label is printed.
+      call_size args
+	| StdCallConv <- cconv = Just (sum (map arg_size args))
+	| otherwise            = Nothing
+
+	-- ToDo: this might not be correct for 64-bit API
+      arg_size arg = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
+
+cgForeignCall _ _ (DNCall _) _
+  = panic "cgForeignCall: DNCall"
+
+emitCCall :: [(CmmFormal,ForeignHint)]
+	  -> CmmExpr 
+	  -> [(CmmActual,ForeignHint)]
+	  -> FCode ()
+emitCCall hinted_results fn hinted_args
+  = emitForeignCall PlayRisky results (ForeignTarget fn fc) args 
+	            NoC_SRT -- No SRT b/c we PlayRisky
+              	    CmmMayReturn
+  where
+    (args, arg_hints) = unzip hinted_args
+    (results, result_hints) = unzip hinted_results
+    target = ForeignTarget fn fc
+    fc = ForeignConvention CCallConv arg_hints result_hints
+    
+
+emitPrimCall :: CmmFormal -> CallishMachOp -> CmmActuals -> FCode ()
+emitPrimCall res op args
+  = emitForeignCall PlayRisky [res] (PrimTarget op) args NoC_SRT CmmMayReturn
+
+-- alternative entry point, used by CmmParse
+emitForeignCall
+	:: Safety
+	-> CmmFormals		-- where to put the results
+	-> MidCallTarget	-- the op
+	-> CmmActuals		-- arguments
+        -> C_SRT                -- the SRT of the calls continuation
+        -> CmmReturnInfo	-- This can say "never returns"
+				--   only RTS procedures do this
+	-> FCode ()
+emitForeignCall safety results target args _srt _ret
+  | not (playSafe safety) = trace "emitForeignCall; ret is undone" $ do
+    let (caller_save, caller_load) = callerSaveVolatileRegs
+    emit caller_save
+    emit (mkUnsafeCall target results args)
+    emit caller_load
+
+  | otherwise = panic "ToDo: emitForeignCall'"
+
+{-
+  | otherwise = do
+    -- Both 'id' and 'new_base' are KindNonPtr because they're
+    -- RTS only objects and are not subject to garbage collection
+    id <- newTemp bWord
+    new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
+    temp_target <- load_target_into_temp target
+    let (caller_save, caller_load) = callerSaveVolatileRegs 
+    emitSaveThreadState
+    emit caller_save
+    -- The CmmUnsafe arguments are only correct because this part
+    -- of the code hasn't been moved into the CPS pass yet.
+    -- Once that happens, this function will just emit a (CmmSafe srt) call,
+    -- and the CPS will will be the one to convert that
+    -- to this sequence of three CmmUnsafe calls.
+    emit (mkCmmCall (CmmCallee suspendThread CCallConv)
+                       [ (id,AddrHint) ]
+                       [ (CmmReg (CmmGlobal BaseReg), AddrHint) ]
+                       CmmUnsafe
+                       ret)
+    emit (mkCmmCall temp_target results args CmmUnsafe ret)
+    emit (mkCmmCall (CmmCallee resumeThread CCallConv)
+                       [ (new_base, AddrHint) ]
+                       [ (CmmReg (CmmLocal id), AddrHint) ]
+                       CmmUnsafe
+                       ret )
+    -- Assign the result to BaseReg: we
+    -- might now have a different Capability!
+    emit (mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
+    emit caller_load
+    emitLoadThreadState
+
+suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread")))
+resumeThread  = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread")))
+-}
+
+
+{-
+--	THINK ABOUT THIS (used to happen)
+-- we might need to load arguments into temporaries before
+-- making the call, because certain global registers might
+-- overlap with registers that the C calling convention uses
+-- for passing arguments.
+--
+-- This is a HACK; really it should be done in the back end, but
+-- it's easier to generate the temporaries here.
+load_args_into_temps = mapM arg_assign_temp
+  where arg_assign_temp (e,hint) = do
+	   tmp <- maybe_assign_temp e
+	   return (tmp,hint)
+	
+load_target_into_temp (CmmCallee expr conv) = do 
+  tmp <- maybe_assign_temp expr
+  return (CmmCallee tmp conv)
+load_target_into_temp other_target =
+  return other_target
+
+maybe_assign_temp e
+  | hasNoGlobalRegs e = return e
+  | otherwise          = do 
+	-- don't use assignTemp, it uses its own notion of "trivial"
+	-- expressions, which are wrong here.
+        -- this is a NonPtr because it only duplicates an existing
+	reg <- newTemp (cmmExprType e) --TODO FIXME NOW
+	emit (mkAssign (CmmLocal reg) e)
+	return (CmmReg (CmmLocal reg))
+-}
+
+-- -----------------------------------------------------------------------------
+-- Save/restore the thread state in the TSO
+
+-- This stuff can't be done in suspendThread/resumeThread, because it
+-- refers to global registers which aren't available in the C world.
+
+emitSaveThreadState :: FCode ()
+emitSaveThreadState = do
+  -- CurrentTSO->sp = Sp;
+  emit $ mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
+  emitCloseNursery
+  -- and save the current cost centre stack in the TSO when profiling:
+  when opt_SccProfilingOn $
+	emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
+
+   -- CurrentNursery->free = Hp+1;
+emitCloseNursery :: FCode ()
+emitCloseNursery = emit $ mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
+
+emitLoadThreadState :: FCode ()
+emitLoadThreadState = do
+  tso <- newTemp gcWord -- TODO FIXME NOW
+  emit $ catAGraphs [
+	-- tso = CurrentTSO;
+  	mkAssign (CmmLocal tso) stgCurrentTSO,
+	-- Sp = tso->sp;
+	mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
+	                      bWord),
+	-- SpLim = tso->stack + RESERVED_STACK_WORDS;
+	mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
+			            rESERVED_STACK_WORDS)
+    ]
+  emitOpenNursery
+  -- and load the current cost centre stack from the TSO when profiling:
+  when opt_SccProfilingOn $
+	emit (mkStore curCCSAddr 
+		(CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType))
+
+emitOpenNursery :: FCode ()
+emitOpenNursery = emit $ catAGraphs [
+        -- Hp = CurrentNursery->free - 1;
+	mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
+
+        -- HpLim = CurrentNursery->start + 
+	--		CurrentNursery->blocks*BLOCK_SIZE_W - 1;
+	mkAssign hpLim
+	    (cmmOffsetExpr
+		(CmmLoad nursery_bdescr_start bWord)
+		(cmmOffset
+		  (CmmMachOp mo_wordMul [
+		    CmmMachOp (MO_SS_Conv W32 wordWidth)
+		      [CmmLoad nursery_bdescr_blocks b32],
+		    CmmLit (mkIntCLit bLOCK_SIZE)
+		   ])
+		  (-1)
+		)
+	    )
+   ]
+
+
+nursery_bdescr_free   = cmmOffset stgCurrentNursery oFFSET_bdescr_free
+nursery_bdescr_start  = cmmOffset stgCurrentNursery oFFSET_bdescr_start
+nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
+
+tso_SP    = tsoFieldB     oFFSET_StgTSO_sp
+tso_STACK = tsoFieldB     oFFSET_StgTSO_stack
+tso_CCCS  = tsoProfFieldB oFFSET_StgTSO_CCCS
+
+-- The TSO struct has a variable header, and an optional StgTSOProfInfo in
+-- the middle.  The fields we're interested in are after the StgTSOProfInfo.
+tsoFieldB :: ByteOff -> ByteOff
+tsoFieldB off
+  | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
+  | otherwise          = off + fixedHdrSize * wORD_SIZE
+
+tsoProfFieldB :: ByteOff -> ByteOff
+tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
+
+stgSp		  = CmmReg sp
+stgHp		  = CmmReg hp
+stgCurrentTSO	  = CmmReg currentTSO
+stgCurrentNursery = CmmReg currentNursery
+
+sp		  = CmmGlobal Sp
+spLim		  = CmmGlobal SpLim
+hp		  = CmmGlobal Hp
+hpLim		  = CmmGlobal HpLim
+currentTSO	  = CmmGlobal CurrentTSO
+currentNursery 	  = CmmGlobal CurrentNursery
+
+-- -----------------------------------------------------------------------------
+-- For certain types passed to foreign calls, we adjust the actual
+-- value passed to the call.  For ByteArray#/Array# we pass the
+-- address of the actual array, not the address of the heap object.
+
+getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
+-- (a) Drop void args
+-- (b) Add foriegn-call shim code
+-- It's (b) that makes this differ from getNonVoidArgAmodes
+
+getFCallArgs args
+  = do	{ mb_cmms <- mapM get args
+	; return (catMaybes mb_cmms) }
+  where
+    get arg | isVoidRep arg_rep 
+	    = return Nothing
+	    | otherwise
+	    = do { cmm <- getArgAmode arg
+		 ; return (Just (add_shim arg_ty cmm, hint)) }
+	    where
+	      arg_ty  = stgArgType arg
+	      arg_rep = typePrimRep arg_ty
+	      hint    = typeForeignHint arg_ty
+
+add_shim :: Type -> CmmExpr -> CmmExpr
+add_shim arg_ty expr
+  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
+  = cmmOffsetB expr arrPtrsHdrSize
+
+  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
+  = cmmOffsetB expr arrWordsHdrSize
+
+  | otherwise = expr
+  where	
+    tycon = tyConAppTyCon (repType arg_ty)
+	-- should be a tycon app, since this is a foreign call