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.

10 files changed, 5339 insertions, 0 deletions

diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
new file mode 100644
index 0000000000..e42b92db5a
--- /dev/null
+++ b/compiler/cmm/CLabel.hs
@@ -0,0 +1,831 @@
+-----------------------------------------------------------------------------
+--
+-- Object-file symbols (called CLabel for histerical raisins).
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CLabel (
+	CLabel,	-- abstract type
+
+	mkClosureLabel,
+	mkSRTLabel,
+	mkSRTDescLabel,
+	mkInfoTableLabel,
+	mkEntryLabel,
+	mkSlowEntryLabel,
+	mkConEntryLabel,
+	mkStaticConEntryLabel,
+	mkRednCountsLabel,
+	mkConInfoTableLabel,
+	mkStaticInfoTableLabel,
+	mkApEntryLabel,
+	mkApInfoTableLabel,
+	mkClosureTableLabel,
+
+	mkLocalClosureLabel,
+	mkLocalInfoTableLabel,
+	mkLocalEntryLabel,
+	mkLocalConEntryLabel,
+	mkLocalStaticConEntryLabel,
+	mkLocalConInfoTableLabel,
+	mkLocalStaticInfoTableLabel,
+	mkLocalClosureTableLabel,
+
+	mkReturnPtLabel,
+	mkReturnInfoLabel,
+	mkAltLabel,
+	mkDefaultLabel,
+	mkBitmapLabel,
+	mkStringLitLabel,
+
+	mkAsmTempLabel,
+
+	mkModuleInitLabel,
+	mkPlainModuleInitLabel,
+
+	mkSplitMarkerLabel,
+	mkDirty_MUT_VAR_Label,
+	mkUpdInfoLabel,
+	mkSeqInfoLabel,
+	mkIndStaticInfoLabel,
+        mkMainCapabilityLabel,
+	mkMAP_FROZEN_infoLabel,
+	mkMAP_DIRTY_infoLabel,
+        mkEMPTY_MVAR_infoLabel,
+
+	mkTopTickyCtrLabel,
+        mkCAFBlackHoleInfoTableLabel,
+        mkSECAFBlackHoleInfoTableLabel,
+	mkRtsPrimOpLabel,
+	mkRtsSlowTickyCtrLabel,
+
+	moduleRegdLabel,
+
+	mkSelectorInfoLabel,
+	mkSelectorEntryLabel,
+
+	mkRtsInfoLabel,
+	mkRtsEntryLabel,
+	mkRtsRetInfoLabel,
+	mkRtsRetLabel,
+	mkRtsCodeLabel,
+	mkRtsDataLabel,
+
+	mkRtsInfoLabelFS,
+	mkRtsEntryLabelFS,
+	mkRtsRetInfoLabelFS,
+	mkRtsRetLabelFS,
+	mkRtsCodeLabelFS,
+	mkRtsDataLabelFS,
+
+	mkRtsApFastLabel,
+
+	mkForeignLabel,
+
+	mkCCLabel, mkCCSLabel,
+
+        DynamicLinkerLabelInfo(..),
+        mkDynamicLinkerLabel,
+        dynamicLinkerLabelInfo,
+        
+        mkPicBaseLabel,
+        mkDeadStripPreventer,
+
+	infoLblToEntryLbl, entryLblToInfoLbl,
+	needsCDecl, isAsmTemp, externallyVisibleCLabel,
+	CLabelType(..), labelType, labelDynamic,
+
+	pprCLabel
+    ) where
+
+
+#include "HsVersions.h"
+
+import Packages		( HomeModules )
+import StaticFlags	( opt_Static, opt_DoTickyProfiling )
+import Packages		( isHomeModule, isDllName )
+import DataCon		( ConTag )
+import Module		( moduleFS, Module )
+import Name		( Name, isExternalName )
+import Unique		( pprUnique, Unique )
+import PrimOp		( PrimOp )
+import Config		( cLeadingUnderscore )
+import CostCentre	( CostCentre, CostCentreStack )
+import Outputable
+import FastString
+
+-- -----------------------------------------------------------------------------
+-- The CLabel type
+
+{-
+CLabel is an abstract type that supports the following operations:
+
+  - Pretty printing
+
+  - In a C file, does it need to be declared before use?  (i.e. is it
+    guaranteed to be already in scope in the places we need to refer to it?)
+
+  - If it needs to be declared, what type (code or data) should it be
+    declared to have?
+
+  - Is it visible outside this object file or not?
+
+  - Is it "dynamic" (see details below)
+
+  - Eq and Ord, so that we can make sets of CLabels (currently only
+    used in outputting C as far as I can tell, to avoid generating
+    more than one declaration for any given label).
+
+  - Converting an info table label into an entry label.
+-}
+
+data CLabel
+  = IdLabel	    		-- A family of labels related to the
+	Name			-- definition of a particular Id or Con
+	IdLabelInfo
+
+  | DynIdLabel			-- like IdLabel, but in a separate package,
+	Name			-- and might therefore need a dynamic
+	IdLabelInfo		-- reference.
+
+  | CaseLabel			-- A family of labels related to a particular
+				-- case expression.
+	{-# UNPACK #-} !Unique	-- Unique says which case expression
+	CaseLabelInfo
+
+  | AsmTempLabel 
+	{-# UNPACK #-} !Unique
+
+  | StringLitLabel
+	{-# UNPACK #-} !Unique
+
+  | ModuleInitLabel 
+	Module			-- the module name
+	String			-- its "way"
+	Bool			-- True <=> is in a different package
+	-- at some point we might want some kind of version number in
+	-- the module init label, to guard against compiling modules in
+	-- the wrong order.  We can't use the interface file version however,
+	-- because we don't always recompile modules which depend on a module
+	-- whose version has changed.
+
+  | PlainModuleInitLabel	-- without the vesrion & way info
+	Module
+	Bool			-- True <=> is in a different package
+
+  | ModuleRegdLabel
+
+  | RtsLabel RtsLabelInfo
+
+  | ForeignLabel FastString	-- a 'C' (or otherwise foreign) label
+	(Maybe Int) 		-- possible '@n' suffix for stdcall functions
+		-- When generating C, the '@n' suffix is omitted, but when
+		-- generating assembler we must add it to the label.
+	Bool			-- True <=> is dynamic
+
+  | CC_Label  CostCentre
+  | CCS_Label CostCentreStack
+
+      -- Dynamic Linking in the NCG:
+      -- generated and used inside the NCG only,
+      -- see module PositionIndependentCode for details.
+      
+  | DynamicLinkerLabel DynamicLinkerLabelInfo CLabel
+        -- special variants of a label used for dynamic linking
+
+  | PicBaseLabel                -- a label used as a base for PIC calculations
+                                -- on some platforms.
+                                -- It takes the form of a local numeric
+                                -- assembler label '1'; it is pretty-printed
+                                -- as 1b, referring to the previous definition
+                                -- of 1: in the assembler source file.
+
+  | DeadStripPreventer CLabel
+    -- label before an info table to prevent excessive dead-stripping on darwin
+
+  deriving (Eq, Ord)
+
+data IdLabelInfo
+  = Closure		-- Label for closure
+  | SRT                 -- Static reference table
+  | SRTDesc             -- Static reference table descriptor
+  | InfoTable		-- Info tables for closures; always read-only
+  | Entry		-- entry point
+  | Slow		-- slow entry point
+
+  | RednCounts		-- Label of place to keep Ticky-ticky  info for 
+			-- this Id
+
+  | Bitmap		-- A bitmap (function or case return)
+
+  | ConEntry	  	-- constructor entry point
+  | ConInfoTable 		-- corresponding info table
+  | StaticConEntry  	-- static constructor entry point
+  | StaticInfoTable   	-- corresponding info table
+
+  | ClosureTable	-- table of closures for Enum tycons
+
+  deriving (Eq, Ord)
+
+
+data CaseLabelInfo
+  = CaseReturnPt
+  | CaseReturnInfo
+  | CaseAlt ConTag
+  | CaseDefault
+  deriving (Eq, Ord)
+
+
+data RtsLabelInfo
+  = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-}	-- Selector thunks
+  | RtsSelectorEntry   Bool{-updatable-} Int{-offset-}
+
+  | RtsApInfoTable Bool{-updatable-} Int{-arity-}	        -- AP thunks
+  | RtsApEntry   Bool{-updatable-} Int{-arity-}
+
+  | RtsPrimOp PrimOp
+
+  | RtsInfo       LitString	-- misc rts info tables
+  | RtsEntry      LitString	-- misc rts entry points
+  | RtsRetInfo    LitString	-- misc rts ret info tables
+  | RtsRet        LitString	-- misc rts return points
+  | RtsData       LitString	-- misc rts data bits, eg CHARLIKE_closure
+  | RtsCode       LitString	-- misc rts code
+
+  | RtsInfoFS     FastString	-- misc rts info tables
+  | RtsEntryFS    FastString	-- misc rts entry points
+  | RtsRetInfoFS  FastString	-- misc rts ret info tables
+  | RtsRetFS      FastString	-- misc rts return points
+  | RtsDataFS     FastString	-- misc rts data bits, eg CHARLIKE_closure
+  | RtsCodeFS     FastString	-- misc rts code
+
+  | RtsApFast	LitString	-- _fast versions of generic apply
+
+  | RtsSlowTickyCtr String
+
+  deriving (Eq, Ord)
+	-- NOTE: Eq on LitString compares the pointer only, so this isn't
+	-- a real equality.
+
+data DynamicLinkerLabelInfo
+  = CodeStub            -- MachO: Lfoo$stub, ELF: foo@plt
+  | SymbolPtr           -- MachO: Lfoo$non_lazy_ptr, Windows: __imp_foo
+  | GotSymbolPtr        -- ELF: foo@got
+  | GotSymbolOffset     -- ELF: foo@gotoff
+  
+  deriving (Eq, Ord)
+  
+-- -----------------------------------------------------------------------------
+-- Constructing CLabels
+
+-- These are always local:
+mkSRTLabel		name 	= IdLabel name  SRT
+mkSRTDescLabel		name 	= IdLabel name  SRTDesc
+mkSlowEntryLabel      	name 	= IdLabel name  Slow
+mkBitmapLabel   	name 	= IdLabel name  Bitmap
+mkRednCountsLabel     	name 	= IdLabel name  RednCounts
+
+-- These have local & (possibly) external variants:
+mkLocalClosureLabel	name 	= IdLabel name  Closure
+mkLocalInfoTableLabel  	name 	= IdLabel name  InfoTable
+mkLocalEntryLabel	name 	= IdLabel name  Entry
+mkLocalClosureTableLabel name	= IdLabel name ClosureTable
+
+mkClosureLabel hmods name
+  | isDllName hmods name = DynIdLabel    name Closure
+  | otherwise             = IdLabel name Closure
+
+mkInfoTableLabel hmods name
+  | isDllName hmods name = DynIdLabel    name InfoTable
+  | otherwise		 = IdLabel name InfoTable
+
+mkEntryLabel hmods name
+  | isDllName hmods name = DynIdLabel    name Entry
+  | otherwise             = IdLabel name Entry
+
+mkClosureTableLabel hmods name
+  | isDllName hmods name = DynIdLabel    name ClosureTable
+  | otherwise             = IdLabel name ClosureTable
+
+mkLocalConInfoTableLabel     con = IdLabel con ConInfoTable
+mkLocalConEntryLabel	     con = IdLabel con ConEntry
+mkLocalStaticInfoTableLabel  con = IdLabel con StaticInfoTable
+mkLocalStaticConEntryLabel   con = IdLabel con StaticConEntry
+
+mkConInfoTableLabel name False = IdLabel    name ConInfoTable
+mkConInfoTableLabel name True  = DynIdLabel name ConInfoTable
+
+mkStaticInfoTableLabel name False = IdLabel    name StaticInfoTable
+mkStaticInfoTableLabel name True  = DynIdLabel name StaticInfoTable
+
+mkConEntryLabel hmods name
+  | isDllName hmods name = DynIdLabel    name ConEntry
+  | otherwise             = IdLabel name ConEntry
+
+mkStaticConEntryLabel hmods name
+  | isDllName hmods name = DynIdLabel    name StaticConEntry
+  | otherwise             = IdLabel name StaticConEntry
+
+
+mkReturnPtLabel uniq		= CaseLabel uniq CaseReturnPt
+mkReturnInfoLabel uniq		= CaseLabel uniq CaseReturnInfo
+mkAltLabel      uniq tag	= CaseLabel uniq (CaseAlt tag)
+mkDefaultLabel  uniq 		= CaseLabel uniq CaseDefault
+
+mkStringLitLabel		= StringLitLabel
+mkAsmTempLabel 			= AsmTempLabel
+
+mkModuleInitLabel :: HomeModules -> Module -> String -> CLabel
+mkModuleInitLabel hmods mod way
+  = ModuleInitLabel mod way $! (not (isHomeModule hmods mod))
+
+mkPlainModuleInitLabel :: HomeModules -> Module -> CLabel
+mkPlainModuleInitLabel hmods mod
+  = PlainModuleInitLabel mod $! (not (isHomeModule hmods mod))
+
+	-- Some fixed runtime system labels
+
+mkSplitMarkerLabel		= RtsLabel (RtsCode SLIT("__stg_split_marker"))
+mkDirty_MUT_VAR_Label		= RtsLabel (RtsCode SLIT("dirty_MUT_VAR"))
+mkUpdInfoLabel			= RtsLabel (RtsInfo SLIT("stg_upd_frame"))
+mkSeqInfoLabel			= RtsLabel (RtsInfo SLIT("stg_seq_frame"))
+mkIndStaticInfoLabel		= RtsLabel (RtsInfo SLIT("stg_IND_STATIC"))
+mkMainCapabilityLabel		= RtsLabel (RtsData SLIT("MainCapability"))
+mkMAP_FROZEN_infoLabel		= RtsLabel (RtsInfo SLIT("stg_MUT_ARR_PTRS_FROZEN0"))
+mkMAP_DIRTY_infoLabel		= RtsLabel (RtsInfo SLIT("stg_MUT_ARR_PTRS_DIRTY"))
+mkEMPTY_MVAR_infoLabel		= RtsLabel (RtsInfo SLIT("stg_EMPTY_MVAR"))
+
+mkTopTickyCtrLabel		= RtsLabel (RtsData SLIT("top_ct"))
+mkCAFBlackHoleInfoTableLabel	= RtsLabel (RtsInfo SLIT("stg_CAF_BLACKHOLE"))
+mkSECAFBlackHoleInfoTableLabel	= if opt_DoTickyProfiling then
+                                    RtsLabel (RtsInfo SLIT("stg_SE_CAF_BLACKHOLE"))
+                                  else  -- RTS won't have info table unless -ticky is on
+                                    panic "mkSECAFBlackHoleInfoTableLabel requires -ticky"
+mkRtsPrimOpLabel primop		= RtsLabel (RtsPrimOp primop)
+
+moduleRegdLabel			= ModuleRegdLabel
+
+mkSelectorInfoLabel  upd off	= RtsLabel (RtsSelectorInfoTable upd off)
+mkSelectorEntryLabel upd off	= RtsLabel (RtsSelectorEntry   upd off)
+
+mkApInfoTableLabel  upd off	= RtsLabel (RtsApInfoTable upd off)
+mkApEntryLabel upd off		= RtsLabel (RtsApEntry   upd off)
+
+	-- Foreign labels
+
+mkForeignLabel :: FastString -> Maybe Int -> Bool -> CLabel
+mkForeignLabel str mb_sz  is_dynamic = ForeignLabel str mb_sz is_dynamic
+
+	-- Cost centres etc.
+
+mkCCLabel	cc		= CC_Label cc
+mkCCSLabel	ccs		= CCS_Label ccs
+
+mkRtsInfoLabel      str = RtsLabel (RtsInfo      str)
+mkRtsEntryLabel     str = RtsLabel (RtsEntry     str)
+mkRtsRetInfoLabel   str = RtsLabel (RtsRetInfo   str)
+mkRtsRetLabel       str = RtsLabel (RtsRet       str)
+mkRtsCodeLabel      str = RtsLabel (RtsCode      str)
+mkRtsDataLabel      str = RtsLabel (RtsData      str)
+
+mkRtsInfoLabelFS    str = RtsLabel (RtsInfoFS    str)
+mkRtsEntryLabelFS   str = RtsLabel (RtsEntryFS   str)
+mkRtsRetInfoLabelFS str = RtsLabel (RtsRetInfoFS str)
+mkRtsRetLabelFS     str = RtsLabel (RtsRetFS     str)
+mkRtsCodeLabelFS    str = RtsLabel (RtsCodeFS    str)
+mkRtsDataLabelFS    str = RtsLabel (RtsDataFS    str)
+
+mkRtsApFastLabel str = RtsLabel (RtsApFast str)
+
+mkRtsSlowTickyCtrLabel :: String -> CLabel
+mkRtsSlowTickyCtrLabel pat = RtsLabel (RtsSlowTickyCtr pat)
+
+        -- Dynamic linking
+        
+mkDynamicLinkerLabel :: DynamicLinkerLabelInfo -> CLabel -> CLabel
+mkDynamicLinkerLabel = DynamicLinkerLabel
+
+dynamicLinkerLabelInfo :: CLabel -> Maybe (DynamicLinkerLabelInfo, CLabel)
+dynamicLinkerLabelInfo (DynamicLinkerLabel info lbl) = Just (info, lbl)
+dynamicLinkerLabelInfo _ = Nothing
+
+        -- Position independent code
+        
+mkPicBaseLabel :: CLabel
+mkPicBaseLabel = PicBaseLabel
+
+mkDeadStripPreventer :: CLabel -> CLabel
+mkDeadStripPreventer lbl = DeadStripPreventer lbl
+
+-- -----------------------------------------------------------------------------
+-- Converting info labels to entry labels.
+
+infoLblToEntryLbl :: CLabel -> CLabel 
+infoLblToEntryLbl (IdLabel n InfoTable) = IdLabel n Entry
+infoLblToEntryLbl (IdLabel n ConInfoTable) = IdLabel n ConEntry
+infoLblToEntryLbl (IdLabel n StaticInfoTable) = IdLabel n StaticConEntry
+infoLblToEntryLbl (DynIdLabel n InfoTable) = DynIdLabel n Entry
+infoLblToEntryLbl (DynIdLabel n ConInfoTable) = DynIdLabel n ConEntry
+infoLblToEntryLbl (DynIdLabel n StaticInfoTable) = DynIdLabel n StaticConEntry
+infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt
+infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s)
+infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s)
+infoLblToEntryLbl (RtsLabel (RtsInfoFS s)) = RtsLabel (RtsEntryFS s)
+infoLblToEntryLbl (RtsLabel (RtsRetInfoFS s)) = RtsLabel (RtsRetFS s)
+infoLblToEntryLbl _ = panic "CLabel.infoLblToEntryLbl"
+
+entryLblToInfoLbl :: CLabel -> CLabel 
+entryLblToInfoLbl (IdLabel n Entry) = IdLabel n InfoTable
+entryLblToInfoLbl (IdLabel n ConEntry) = IdLabel n ConInfoTable
+entryLblToInfoLbl (IdLabel n StaticConEntry) = IdLabel n StaticInfoTable
+entryLblToInfoLbl (DynIdLabel n Entry) = DynIdLabel n InfoTable
+entryLblToInfoLbl (DynIdLabel n ConEntry) = DynIdLabel n ConInfoTable
+entryLblToInfoLbl (DynIdLabel n StaticConEntry) = DynIdLabel n StaticInfoTable
+entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo
+entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s)
+entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s)
+entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s)
+entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s)
+entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l)
+
+-- -----------------------------------------------------------------------------
+-- Does a CLabel need declaring before use or not?
+
+needsCDecl :: CLabel -> Bool
+  -- False <=> it's pre-declared; don't bother
+  -- don't bother declaring SRT & Bitmap labels, we always make sure
+  -- they are defined before use.
+needsCDecl (IdLabel _ SRT)		= False
+needsCDecl (IdLabel _ SRTDesc)		= False
+needsCDecl (IdLabel _ Bitmap)		= False
+needsCDecl (IdLabel _ _)		= True
+needsCDecl (DynIdLabel _ _)		= True
+needsCDecl (CaseLabel _ _)	        = True
+needsCDecl (ModuleInitLabel _ _ _)	= True
+needsCDecl (PlainModuleInitLabel _ _)	= True
+needsCDecl ModuleRegdLabel		= False
+
+needsCDecl (StringLitLabel _)		= False
+needsCDecl (AsmTempLabel _)		= False
+needsCDecl (RtsLabel _)			= False
+needsCDecl (ForeignLabel _ _ _)		= False
+needsCDecl (CC_Label _)			= True
+needsCDecl (CCS_Label _)		= True
+
+-- Whether the label is an assembler temporary:
+
+isAsmTemp  :: CLabel -> Bool    -- is a local temporary for native code generation
+isAsmTemp (AsmTempLabel _) = True
+isAsmTemp _ 	    	   = False
+
+-- -----------------------------------------------------------------------------
+-- Is a CLabel visible outside this object file or not?
+
+-- From the point of view of the code generator, a name is
+-- externally visible if it has to be declared as exported
+-- in the .o file's symbol table; that is, made non-static.
+
+externallyVisibleCLabel :: CLabel -> Bool -- not C "static"
+externallyVisibleCLabel (CaseLabel _ _)	   = False
+externallyVisibleCLabel (StringLitLabel _) = False
+externallyVisibleCLabel (AsmTempLabel _)   = False
+externallyVisibleCLabel (ModuleInitLabel _ _ _)= True
+externallyVisibleCLabel (PlainModuleInitLabel _ _)= True
+externallyVisibleCLabel ModuleRegdLabel    = False
+externallyVisibleCLabel (RtsLabel _)	   = True
+externallyVisibleCLabel (ForeignLabel _ _ _) = True
+externallyVisibleCLabel (IdLabel name _)     = isExternalName name
+externallyVisibleCLabel (DynIdLabel name _)  = isExternalName name
+externallyVisibleCLabel (CC_Label _)	   = True
+externallyVisibleCLabel (CCS_Label _)	   = True
+externallyVisibleCLabel (DynamicLinkerLabel _ _)  = False
+
+-- -----------------------------------------------------------------------------
+-- Finding the "type" of a CLabel 
+
+-- For generating correct types in label declarations:
+
+data CLabelType
+  = CodeLabel
+  | DataLabel
+
+labelType :: CLabel -> CLabelType
+labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel
+labelType (RtsLabel (RtsApInfoTable _ _))       = DataLabel
+labelType (RtsLabel (RtsData _))              = DataLabel
+labelType (RtsLabel (RtsCode _))              = CodeLabel
+labelType (RtsLabel (RtsInfo _))              = DataLabel
+labelType (RtsLabel (RtsEntry _))             = CodeLabel
+labelType (RtsLabel (RtsRetInfo _))           = DataLabel
+labelType (RtsLabel (RtsRet _))               = CodeLabel
+labelType (RtsLabel (RtsDataFS _))            = DataLabel
+labelType (RtsLabel (RtsCodeFS _))            = CodeLabel
+labelType (RtsLabel (RtsInfoFS _))            = DataLabel
+labelType (RtsLabel (RtsEntryFS _))           = CodeLabel
+labelType (RtsLabel (RtsRetInfoFS _))         = DataLabel
+labelType (RtsLabel (RtsRetFS _))             = CodeLabel
+labelType (RtsLabel (RtsApFast _))            = CodeLabel
+labelType (CaseLabel _ CaseReturnInfo)        = DataLabel
+labelType (CaseLabel _ _)	              = CodeLabel
+labelType (ModuleInitLabel _ _ _)             = CodeLabel
+labelType (PlainModuleInitLabel _ _)          = CodeLabel
+
+labelType (IdLabel _ info) = idInfoLabelType info
+labelType (DynIdLabel _ info) = idInfoLabelType info
+labelType _        = DataLabel
+
+idInfoLabelType info =
+  case info of
+    InfoTable  	  -> DataLabel
+    Closure    	  -> DataLabel
+    Bitmap     	  -> DataLabel
+    ConInfoTable  -> DataLabel
+    StaticInfoTable -> DataLabel
+    ClosureTable  -> DataLabel
+    _	          -> CodeLabel
+
+
+-- -----------------------------------------------------------------------------
+-- Does a CLabel need dynamic linkage?
+
+-- When referring to data in code, we need to know whether
+-- that data resides in a DLL or not. [Win32 only.]
+-- @labelDynamic@ returns @True@ if the label is located
+-- in a DLL, be it a data reference or not.
+
+labelDynamic :: CLabel -> Bool
+labelDynamic lbl = 
+  case lbl of
+   RtsLabel _  	     -> not opt_Static  -- i.e., is the RTS in a DLL or not?
+   IdLabel n k       -> False
+   DynIdLabel n k    -> True
+#if mingw32_TARGET_OS
+   ForeignLabel _ _ d  -> d
+#else
+   -- On Mac OS X and on ELF platforms, false positives are OK,
+   -- so we claim that all foreign imports come from dynamic libraries
+   ForeignLabel _ _ _ -> True
+#endif
+   ModuleInitLabel m _ dyn    -> not opt_Static && dyn
+   PlainModuleInitLabel m dyn -> not opt_Static && dyn
+   
+   -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves.
+   _ 		     -> False
+
+{-
+OLD?: These GRAN functions are needed for spitting out GRAN_FETCH() at the
+right places. It is used to detect when the abstractC statement of an
+CCodeBlock actually contains the code for a slow entry point.  -- HWL
+
+We need at least @Eq@ for @CLabels@, because we want to avoid
+duplicate declarations in generating C (see @labelSeenTE@ in
+@PprAbsC@).
+-}
+
+-----------------------------------------------------------------------------
+-- Printing out CLabels.
+
+{-
+Convention:
+
+      <name>_<type>
+
+where <name> is <Module>_<name> for external names and <unique> for
+internal names. <type> is one of the following:
+
+	 info			Info table
+	 srt			Static reference table
+	 srtd			Static reference table descriptor
+	 entry			Entry code (function, closure)
+	 slow			Slow entry code (if any)
+	 ret			Direct return address	 
+	 vtbl			Vector table
+	 <n>_alt		Case alternative (tag n)
+	 dflt			Default case alternative
+	 btm			Large bitmap vector
+	 closure		Static closure
+	 con_entry		Dynamic Constructor entry code
+	 con_info		Dynamic Constructor info table
+	 static_entry		Static Constructor entry code
+	 static_info		Static Constructor info table
+	 sel_info		Selector info table
+	 sel_entry		Selector entry code
+	 cc			Cost centre
+	 ccs			Cost centre stack
+
+Many of these distinctions are only for documentation reasons.  For
+example, _ret is only distinguished from _entry to make it easy to
+tell whether a code fragment is a return point or a closure/function
+entry.
+-}
+
+instance Outputable CLabel where
+  ppr = pprCLabel
+
+pprCLabel :: CLabel -> SDoc
+
+#if ! OMIT_NATIVE_CODEGEN
+pprCLabel (AsmTempLabel u)
+  =  getPprStyle $ \ sty ->
+     if asmStyle sty then 
+	ptext asmTempLabelPrefix <> pprUnique u
+     else
+	char '_' <> pprUnique u
+
+pprCLabel (DynamicLinkerLabel info lbl)
+   = pprDynamicLinkerAsmLabel info lbl
+   
+pprCLabel PicBaseLabel
+   = ptext SLIT("1b")
+   
+pprCLabel (DeadStripPreventer lbl)
+   = pprCLabel lbl <> ptext SLIT("_dsp")
+#endif
+
+pprCLabel lbl = 
+#if ! OMIT_NATIVE_CODEGEN
+    getPprStyle $ \ sty ->
+    if asmStyle sty then 
+	maybe_underscore (pprAsmCLbl lbl)
+    else
+#endif
+       pprCLbl lbl
+
+maybe_underscore doc
+  | underscorePrefix = pp_cSEP <> doc
+  | otherwise        = doc
+
+#ifdef mingw32_TARGET_OS
+-- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
+-- (The C compiler does this itself).
+pprAsmCLbl (ForeignLabel fs (Just sz) _)
+   = ftext fs <> char '@' <> int sz
+#endif
+pprAsmCLbl lbl
+   = pprCLbl lbl
+
+pprCLbl (StringLitLabel u)
+  = pprUnique u <> ptext SLIT("_str")
+
+pprCLbl (CaseLabel u CaseReturnPt)
+  = hcat [pprUnique u, ptext SLIT("_ret")]
+pprCLbl (CaseLabel u CaseReturnInfo)
+  = hcat [pprUnique u, ptext SLIT("_info")]
+pprCLbl (CaseLabel u (CaseAlt tag))
+  = hcat [pprUnique u, pp_cSEP, int tag, ptext SLIT("_alt")]
+pprCLbl (CaseLabel u CaseDefault)
+  = hcat [pprUnique u, ptext SLIT("_dflt")]
+
+pprCLbl (RtsLabel (RtsCode str))   = ptext str
+pprCLbl (RtsLabel (RtsData str))   = ptext str
+pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str
+pprCLbl (RtsLabel (RtsDataFS str)) = ftext str
+
+pprCLbl (RtsLabel (RtsApFast str)) = ptext str <> ptext SLIT("_fast")
+
+pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset))
+  = hcat [ptext SLIT("stg_sel_"), text (show offset),
+		ptext (if upd_reqd 
+			then SLIT("_upd_info") 
+			else SLIT("_noupd_info"))
+	]
+
+pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset))
+  = hcat [ptext SLIT("stg_sel_"), text (show offset),
+		ptext (if upd_reqd 
+			then SLIT("_upd_entry") 
+			else SLIT("_noupd_entry"))
+	]
+
+pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity))
+  = hcat [ptext SLIT("stg_ap_"), text (show arity),
+		ptext (if upd_reqd 
+			then SLIT("_upd_info") 
+			else SLIT("_noupd_info"))
+	]
+
+pprCLbl (RtsLabel (RtsApEntry upd_reqd arity))
+  = hcat [ptext SLIT("stg_ap_"), text (show arity),
+		ptext (if upd_reqd 
+			then SLIT("_upd_entry") 
+			else SLIT("_noupd_entry"))
+	]
+
+pprCLbl (RtsLabel (RtsInfo fs))
+  = ptext fs <> ptext SLIT("_info")
+
+pprCLbl (RtsLabel (RtsEntry fs))
+  = ptext fs <> ptext SLIT("_entry")
+
+pprCLbl (RtsLabel (RtsRetInfo fs))
+  = ptext fs <> ptext SLIT("_info")
+
+pprCLbl (RtsLabel (RtsRet fs))
+  = ptext fs <> ptext SLIT("_ret")
+
+pprCLbl (RtsLabel (RtsInfoFS fs))
+  = ftext fs <> ptext SLIT("_info")
+
+pprCLbl (RtsLabel (RtsEntryFS fs))
+  = ftext fs <> ptext SLIT("_entry")
+
+pprCLbl (RtsLabel (RtsRetInfoFS fs))
+  = ftext fs <> ptext SLIT("_info")
+
+pprCLbl (RtsLabel (RtsRetFS fs))
+  = ftext fs <> ptext SLIT("_ret")
+
+pprCLbl (RtsLabel (RtsPrimOp primop)) 
+  = ppr primop <> ptext SLIT("_fast")
+
+pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) 
+  = ptext SLIT("SLOW_CALL_") <> text pat <> ptext SLIT("_ctr")
+
+pprCLbl ModuleRegdLabel
+  = ptext SLIT("_module_registered")
+
+pprCLbl (ForeignLabel str _ _)
+  = ftext str
+
+pprCLbl (IdLabel name  flavor) = ppr name <> ppIdFlavor flavor
+pprCLbl (DynIdLabel name  flavor) = ppr name <> ppIdFlavor flavor
+
+pprCLbl (CC_Label cc) 		= ppr cc
+pprCLbl (CCS_Label ccs) 	= ppr ccs
+
+pprCLbl (ModuleInitLabel mod way _)	
+   = ptext SLIT("__stginit_") <> ppr mod
+	<> char '_' <> text way
+pprCLbl (PlainModuleInitLabel mod _)	
+   = ptext SLIT("__stginit_") <> ppr mod
+
+ppIdFlavor :: IdLabelInfo -> SDoc
+ppIdFlavor x = pp_cSEP <>
+	       (case x of
+		       Closure	    	-> ptext SLIT("closure")
+		       SRT		-> ptext SLIT("srt")
+		       SRTDesc		-> ptext SLIT("srtd")
+		       InfoTable    	-> ptext SLIT("info")
+		       Entry	    	-> ptext SLIT("entry")
+		       Slow	    	-> ptext SLIT("slow")
+		       RednCounts	-> ptext SLIT("ct")
+		       Bitmap		-> ptext SLIT("btm")
+		       ConEntry	    	-> ptext SLIT("con_entry")
+		       ConInfoTable    	-> ptext SLIT("con_info")
+		       StaticConEntry  	-> ptext SLIT("static_entry")
+		       StaticInfoTable 	-> ptext SLIT("static_info")
+		       ClosureTable     -> ptext SLIT("closure_tbl")
+		      )
+
+
+pp_cSEP = char '_'
+
+-- -----------------------------------------------------------------------------
+-- Machine-dependent knowledge about labels.
+
+underscorePrefix :: Bool   -- leading underscore on assembler labels?
+underscorePrefix = (cLeadingUnderscore == "YES")
+
+asmTempLabelPrefix :: LitString  -- for formatting labels
+asmTempLabelPrefix =
+#if alpha_TARGET_OS
+     {- The alpha assembler likes temporary labels to look like $L123
+	instead of L123.  (Don't toss the L, because then Lf28
+	turns into $f28.)
+     -}
+     SLIT("$")
+#elif darwin_TARGET_OS
+     SLIT("L")
+#else
+     SLIT(".L")
+#endif
+
+pprDynamicLinkerAsmLabel :: DynamicLinkerLabelInfo -> CLabel -> SDoc
+
+#if darwin_TARGET_OS
+pprDynamicLinkerAsmLabel SymbolPtr lbl
+  = char 'L' <> pprCLabel lbl <> text "$non_lazy_ptr"
+pprDynamicLinkerAsmLabel CodeStub lbl
+  = char 'L' <> pprCLabel lbl <> text "$stub"
+#elif powerpc_TARGET_ARCH && linux_TARGET_OS
+pprDynamicLinkerAsmLabel CodeStub lbl
+  = pprCLabel lbl <> text "@plt"
+pprDynamicLinkerAsmLabel SymbolPtr lbl
+  = text ".LC_" <> pprCLabel lbl
+#elif linux_TARGET_OS
+pprDynamicLinkerAsmLabel CodeStub lbl
+  = pprCLabel lbl <> text "@plt"
+pprDynamicLinkerAsmLabel GotSymbolPtr lbl
+  = pprCLabel lbl <> text "@got"
+pprDynamicLinkerAsmLabel GotSymbolOffset lbl
+  = pprCLabel lbl <> text "@gotoff"
+pprDynamicLinkerAsmLabel SymbolPtr lbl
+  = text ".LC_" <> pprCLabel lbl
+#elif mingw32_TARGET_OS
+pprDynamicLinkerAsmLabel SymbolPtr lbl
+  = text "__imp_" <> pprCLabel lbl
+#endif
+pprDynamicLinkerAsmLabel _ _
+  = panic "pprDynamicLinkerAsmLabel"
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
new file mode 100644
index 0000000000..13961c15d3
--- /dev/null
+++ b/compiler/cmm/Cmm.hs
@@ -0,0 +1,322 @@
+-----------------------------------------------------------------------------
+--
+-- Cmm data types
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module Cmm ( 
+	GenCmm(..), Cmm,
+	GenCmmTop(..), CmmTop,
+	GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts,
+	CmmStmt(..),  
+	CmmCallTarget(..),
+	CmmStatic(..), Section(..),
+	CmmExpr(..), cmmExprRep, 
+	CmmReg(..), cmmRegRep,
+	CmmLit(..), cmmLitRep,
+	LocalReg(..), localRegRep,
+	BlockId(..),
+	GlobalReg(..), globalRegRep,
+
+	node, nodeReg, spReg, hpReg,
+  ) where
+
+#include "HsVersions.h"
+
+import MachOp
+import CLabel		( CLabel )
+import ForeignCall	( CCallConv )
+import Unique		( Unique, Uniquable(..) )
+import FastString	( FastString )
+import DATA_WORD	( Word8 )
+
+-----------------------------------------------------------------------------
+--		Cmm, CmmTop, CmmBasicBlock
+-----------------------------------------------------------------------------
+
+-- A file is a list of top-level chunks.  These may be arbitrarily
+-- re-orderd during code generation.
+
+-- GenCmm is abstracted over
+--   (a) the type of static data elements
+--   (b) the contents of a basic block.
+-- We expect there to be two main instances of this type:
+--   (a) Plain C--, i.e. populated with CmmLit and CmmExpr respectively,
+--   (b) Native code, populated with instructions
+--
+newtype GenCmm d i = Cmm [GenCmmTop d i]
+
+type Cmm = GenCmm CmmStatic CmmStmt
+
+-- A top-level chunk, abstracted over the type of the contents of
+-- the basic blocks (Cmm or instructions are the likely instantiations).
+data GenCmmTop d i
+  = CmmProc
+     [d]	       -- Info table, may be empty
+     CLabel            -- Used to generate both info & entry labels
+     [LocalReg]        -- Argument locals live on entry (C-- procedure params)
+     [GenBasicBlock i] -- Code, may be empty.  The first block is
+                       -- the entry point.  The order is otherwise initially 
+                       -- unimportant, but at some point the code gen will
+                       -- fix the order.
+
+		       -- the BlockId of the first block does not give rise
+		       -- to a label.  To jump to the first block in a Proc,
+		       -- use the appropriate CLabel.
+
+  -- some static data.
+  | CmmData Section [d]	-- constant values only
+
+type CmmTop = GenCmmTop CmmStatic CmmStmt
+
+-- A basic block containing a single label, at the beginning.
+-- The list of basic blocks in a top-level code block may be re-ordered.
+-- Fall-through is not allowed: there must be an explicit jump at the
+-- end of each basic block, but the code generator might rearrange basic
+-- blocks in order to turn some jumps into fallthroughs.
+
+data GenBasicBlock i = BasicBlock BlockId [i]
+  -- ToDo: Julian suggests that we might need to annotate this type
+  -- with the out & in edges in the graph, i.e. two * [BlockId].  This
+  -- information can be derived from the contents, but it might be
+  -- helpful to cache it here.
+
+type CmmBasicBlock = GenBasicBlock CmmStmt
+
+blockId :: GenBasicBlock i -> BlockId
+-- The branch block id is that of the first block in 
+-- the branch, which is that branch's entry point
+blockId (BasicBlock blk_id _ ) = blk_id
+
+blockStmts :: GenBasicBlock i -> [i]
+blockStmts (BasicBlock _ stmts) = stmts
+
+
+-----------------------------------------------------------------------------
+--		CmmStmt
+-- A "statement".  Note that all branches are explicit: there are no
+-- control transfers to computed addresses, except when transfering
+-- control to a new function.
+-----------------------------------------------------------------------------
+
+data CmmStmt
+  = CmmNop
+  | CmmComment FastString
+
+  | CmmAssign CmmReg CmmExpr	 -- Assign to register
+
+  | CmmStore CmmExpr CmmExpr     -- Assign to memory location.  Size is
+                                 -- given by cmmExprRep of the rhs.
+
+  | CmmCall	 		 -- A foreign call, with 
+     CmmCallTarget
+     [(CmmReg,MachHint)]	 -- zero or more results
+     [(CmmExpr,MachHint)]	 -- zero or more arguments
+     (Maybe [GlobalReg])	 -- Global regs that may need to be saved
+				 -- if they will be clobbered by the call.
+				 -- Nothing <=> save *all* globals that
+				 -- might be clobbered.
+
+  | CmmBranch BlockId             -- branch to another BB in this fn
+
+  | CmmCondBranch CmmExpr BlockId -- conditional branch
+
+  | CmmSwitch CmmExpr [Maybe BlockId]   -- Table branch
+	-- The scrutinee is zero-based; 
+	--	zero -> first block
+	--	one  -> second block etc
+	-- Undefined outside range, and when there's a Nothing
+
+  | CmmJump CmmExpr [LocalReg]    -- Jump to another function, with these 
+				  -- parameters.
+
+-----------------------------------------------------------------------------
+--		CmmCallTarget
+--
+-- The target of a CmmCall.
+-----------------------------------------------------------------------------
+
+data CmmCallTarget
+  = CmmForeignCall		-- Call to a foreign function
+	CmmExpr 		-- literal label <=> static call
+				-- other expression <=> dynamic call
+	CCallConv		-- The calling convention
+
+  | CmmPrim			-- Call to a "primitive" (eg. sin, cos)
+	CallishMachOp		-- These might be implemented as inline
+				-- code by the backend.
+
+-----------------------------------------------------------------------------
+--		CmmExpr
+-- An expression.  Expressions have no side effects.
+-----------------------------------------------------------------------------
+
+data CmmExpr
+  = CmmLit CmmLit               -- Literal
+  | CmmLoad CmmExpr MachRep     -- Read memory location
+  | CmmReg CmmReg		-- Contents of register
+  | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)
+  | CmmRegOff CmmReg Int	
+	-- CmmRegOff reg i
+	--        ** is shorthand only, meaning **
+	-- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep)))
+	--	where rep = cmmRegRep reg
+
+cmmExprRep :: CmmExpr -> MachRep
+cmmExprRep (CmmLit lit)      = cmmLitRep lit
+cmmExprRep (CmmLoad _ rep)   = rep
+cmmExprRep (CmmReg reg)      = cmmRegRep reg
+cmmExprRep (CmmMachOp op _)  = resultRepOfMachOp op
+cmmExprRep (CmmRegOff reg _) = cmmRegRep reg
+
+data CmmReg 
+  = CmmLocal  LocalReg
+  | CmmGlobal GlobalReg
+  deriving( Eq )
+
+cmmRegRep :: CmmReg -> MachRep
+cmmRegRep (CmmLocal  reg) 	= localRegRep reg
+cmmRegRep (CmmGlobal reg)	= globalRegRep reg
+
+data LocalReg
+  = LocalReg !Unique MachRep
+
+instance Eq LocalReg where
+  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
+
+instance Uniquable LocalReg where
+  getUnique (LocalReg uniq _) = uniq
+
+localRegRep :: LocalReg -> MachRep
+localRegRep (LocalReg _ rep) = rep
+
+data CmmLit
+  = CmmInt Integer  MachRep
+	-- Interpretation: the 2's complement representation of the value
+	-- is truncated to the specified size.  This is easier than trying
+	-- to keep the value within range, because we don't know whether
+	-- it will be used as a signed or unsigned value (the MachRep doesn't
+	-- distinguish between signed & unsigned).
+  | CmmFloat  Rational MachRep
+  | CmmLabel    CLabel			-- Address of label
+  | CmmLabelOff CLabel Int		-- Address of label + byte offset
+  
+        -- Due to limitations in the C backend, the following
+        -- MUST ONLY be used inside the info table indicated by label2
+        -- (label2 must be the info label), and label1 must be an
+        -- SRT, a slow entrypoint or a large bitmap (see the Mangler)
+        -- Don't use it at all unless tablesNextToCode.
+        -- It is also used inside the NCG during when generating
+        -- position-independent code. 
+  | CmmLabelDiffOff CLabel CLabel Int   -- label1 - label2 + offset
+
+cmmLitRep :: CmmLit -> MachRep
+cmmLitRep (CmmInt _ rep)    = rep
+cmmLitRep (CmmFloat _ rep)  = rep
+cmmLitRep (CmmLabel _)      = wordRep
+cmmLitRep (CmmLabelOff _ _) = wordRep
+cmmLitRep (CmmLabelDiffOff _ _ _) = wordRep
+
+-----------------------------------------------------------------------------
+-- A local label.
+
+-- Local labels must be unique within a single compilation unit.
+
+newtype BlockId = BlockId Unique
+  deriving (Eq,Ord)
+
+instance Uniquable BlockId where
+  getUnique (BlockId u) = u
+
+-----------------------------------------------------------------------------
+--		Static Data
+-----------------------------------------------------------------------------
+
+data Section
+  = Text
+  | Data
+  | ReadOnlyData
+  | RelocatableReadOnlyData
+  | UninitialisedData
+  | ReadOnlyData16	-- .rodata.cst16 on x86_64, 16-byte aligned
+  | OtherSection String
+
+data CmmStatic
+  = CmmStaticLit CmmLit	
+	-- a literal value, size given by cmmLitRep of the literal.
+  | CmmUninitialised Int
+	-- uninitialised data, N bytes long
+  | CmmAlign Int
+	-- align to next N-byte boundary (N must be a power of 2).
+  | CmmDataLabel CLabel
+	-- label the current position in this section.
+  | CmmString [Word8]
+	-- string of 8-bit values only, not zero terminated.
+
+-----------------------------------------------------------------------------
+--		Global STG registers
+-----------------------------------------------------------------------------
+
+data GlobalReg
+  -- Argument and return registers
+  = VanillaReg			-- pointers, unboxed ints and chars
+	{-# UNPACK #-} !Int	-- its number
+
+  | FloatReg		-- single-precision floating-point registers
+	{-# UNPACK #-} !Int	-- its number
+
+  | DoubleReg		-- double-precision floating-point registers
+	{-# UNPACK #-} !Int	-- its number
+
+  | LongReg	        -- long int registers (64-bit, really)
+	{-# UNPACK #-} !Int	-- its number
+
+  -- STG registers
+  | Sp			-- Stack ptr; points to last occupied stack location.
+  | SpLim		-- Stack limit
+  | Hp			-- Heap ptr; points to last occupied heap location.
+  | HpLim		-- Heap limit register
+  | CurrentTSO		-- pointer to current thread's TSO
+  | CurrentNursery	-- pointer to allocation area
+  | HpAlloc		-- allocation count for heap check failure
+
+		-- We keep the address of some commonly-called 
+		-- functions in the register table, to keep code
+		-- size down:
+  | GCEnter1		-- stg_gc_enter_1
+  | GCFun		-- stg_gc_fun
+
+  -- Base offset for the register table, used for accessing registers
+  -- which do not have real registers assigned to them.  This register
+  -- will only appear after we have expanded GlobalReg into memory accesses
+  -- (where necessary) in the native code generator.
+  | BaseReg
+
+  -- Base Register for PIC (position-independent code) calculations
+  -- Only used inside the native code generator. It's exact meaning differs
+  -- from platform to platform (see module PositionIndependentCode).
+  | PicBaseReg
+
+  deriving( Eq
+#ifdef DEBUG
+	, Show
+#endif
+	 )
+
+-- convenient aliases
+spReg, hpReg, nodeReg :: CmmReg
+spReg = CmmGlobal Sp
+hpReg = CmmGlobal Hp
+nodeReg = CmmGlobal node
+
+node :: GlobalReg
+node = VanillaReg 1
+
+globalRegRep :: GlobalReg -> MachRep
+globalRegRep (VanillaReg _) 	= wordRep
+globalRegRep (FloatReg _) 	= F32
+globalRegRep (DoubleReg _) 	= F64
+globalRegRep (LongReg _) 	= I64
+globalRegRep _			= wordRep
diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x
new file mode 100644
index 0000000000..c2efd17710
--- /dev/null
+++ b/compiler/cmm/CmmLex.x
@@ -0,0 +1,311 @@
+-----------------------------------------------------------------------------
+-- (c) The University of Glasgow, 2004
+--
+-- Lexer for concrete Cmm.  We try to stay close to the C-- spec, but there
+-- are a few minor differences:
+--
+--   * extra keywords for our macros, and float32/float64 types
+--   * global registers (Sp,Hp, etc.)
+--
+-----------------------------------------------------------------------------
+
+{
+module CmmLex (
+   CmmToken(..), cmmlex,
+  ) where
+
+#include "HsVersions.h"
+
+import Cmm
+import Lexer
+
+import SrcLoc
+import UniqFM
+import StringBuffer
+import FastString
+import Ctype
+import Util		( readRational )
+--import TRACE
+}
+
+$whitechar   = [\ \t\n\r\f\v\xa0]
+$white_no_nl = $whitechar # \n
+
+$ascdigit  = 0-9
+$unidigit  = \x01
+$digit     = [$ascdigit $unidigit]
+$octit	   = 0-7
+$hexit     = [$digit A-F a-f]
+
+$unilarge  = \x03
+$asclarge  = [A-Z \xc0-\xd6 \xd8-\xde]
+$large     = [$asclarge $unilarge]
+
+$unismall  = \x04
+$ascsmall  = [a-z \xdf-\xf6 \xf8-\xff]
+$small     = [$ascsmall $unismall \_]
+
+$namebegin = [$large $small \_ \. \$ \@]
+$namechar  = [$namebegin $digit]
+
+@decimal     = $digit+
+@octal       = $octit+
+@hexadecimal = $hexit+
+@exponent    = [eE] [\-\+]? @decimal
+
+@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent
+
+@escape      = \\ ([abfnrt\\\'\"\?] | x @hexadecimal | @octal)
+@strchar     = ($printable # [\"\\]) | @escape
+
+cmm :-
+
+$white_no_nl+		;
+^\# pragma .* \n        ; -- Apple GCC 3.3 CPP generates pragmas in its output
+
+^\# (line)? 		{ begin line_prag }
+
+-- single-line line pragmas, of the form
+--    # <line> "<file>" <extra-stuff> \n
+<line_prag> $digit+			{ setLine line_prag1 }
+<line_prag1> \" ($printable # \")* \"	{ setFile line_prag2 }
+<line_prag2> .*				{ pop }
+
+<0> {
+  \n			;
+
+  [\:\;\{\}\[\]\(\)\=\`\~\/\*\%\-\+\&\^\|\>\<\,\!]	{ special_char }
+  
+  ".." 			{ kw CmmT_DotDot }
+  "::" 			{ kw CmmT_DoubleColon }
+  ">>"			{ kw CmmT_Shr }
+  "<<"			{ kw CmmT_Shl }
+  ">="			{ kw CmmT_Ge }
+  "<="			{ kw CmmT_Le }
+  "=="			{ kw CmmT_Eq }
+  "!="			{ kw CmmT_Ne }
+  "&&"			{ kw CmmT_BoolAnd }
+  "||"			{ kw CmmT_BoolOr }
+  
+  R@decimal		{ global_regN VanillaReg }
+  F@decimal		{ global_regN FloatReg }
+  D@decimal		{ global_regN DoubleReg }
+  L@decimal		{ global_regN LongReg }
+  Sp			{ global_reg Sp }
+  SpLim			{ global_reg SpLim }
+  Hp			{ global_reg Hp }
+  HpLim			{ global_reg HpLim }
+  CurrentTSO		{ global_reg CurrentTSO }
+  CurrentNursery	{ global_reg CurrentNursery }
+  HpAlloc		{ global_reg HpAlloc }
+  BaseReg		{ global_reg BaseReg }
+  
+  $namebegin $namechar*	{ name }
+  
+  0 @octal		{ tok_octal }
+  @decimal		{ tok_decimal }
+  0[xX] @hexadecimal	{ tok_hexadecimal }
+  @floating_point	{ strtoken tok_float }
+  
+  \" @strchar* \"	{ strtoken tok_string }
+}
+
+{
+data CmmToken
+  = CmmT_SpecChar  Char
+  | CmmT_DotDot
+  | CmmT_DoubleColon
+  | CmmT_Shr
+  | CmmT_Shl
+  | CmmT_Ge
+  | CmmT_Le
+  | CmmT_Eq
+  | CmmT_Ne
+  | CmmT_BoolAnd
+  | CmmT_BoolOr
+  | CmmT_CLOSURE
+  | CmmT_INFO_TABLE
+  | CmmT_INFO_TABLE_RET
+  | CmmT_INFO_TABLE_FUN
+  | CmmT_INFO_TABLE_CONSTR
+  | CmmT_INFO_TABLE_SELECTOR
+  | CmmT_else
+  | CmmT_export
+  | CmmT_section
+  | CmmT_align
+  | CmmT_goto
+  | CmmT_if
+  | CmmT_jump
+  | CmmT_foreign
+  | CmmT_import
+  | CmmT_switch
+  | CmmT_case
+  | CmmT_default
+  | CmmT_bits8
+  | CmmT_bits16
+  | CmmT_bits32
+  | CmmT_bits64
+  | CmmT_float32
+  | CmmT_float64
+  | CmmT_GlobalReg GlobalReg
+  | CmmT_Name	   FastString
+  | CmmT_String	   String
+  | CmmT_Int	   Integer
+  | CmmT_Float     Rational
+  | CmmT_EOF
+#ifdef DEBUG
+  deriving (Show)
+#endif
+
+-- -----------------------------------------------------------------------------
+-- Lexer actions
+
+type Action = SrcSpan -> StringBuffer -> Int -> P (Located CmmToken)
+
+begin :: Int -> Action
+begin code _span _str _len = do pushLexState code; lexToken
+
+pop :: Action
+pop _span _buf _len = do popLexState; lexToken
+
+special_char :: Action
+special_char span buf len = return (L span (CmmT_SpecChar (currentChar buf)))
+
+kw :: CmmToken -> Action
+kw tok span buf len = return (L span tok)
+
+global_regN :: (Int -> GlobalReg) -> Action
+global_regN con span buf len 
+  = return (L span (CmmT_GlobalReg (con (fromIntegral n))))
+  where buf' = stepOn buf
+	n = parseInteger buf' (len-1) 10 octDecDigit
+
+global_reg :: GlobalReg -> Action
+global_reg r span buf len = return (L span (CmmT_GlobalReg r))
+
+strtoken :: (String -> CmmToken) -> Action
+strtoken f span buf len = 
+  return (L span $! (f $! lexemeToString buf len))
+
+name :: Action
+name span buf len = 
+  case lookupUFM reservedWordsFM fs of
+	Just tok -> return (L span tok)
+	Nothing  -> return (L span (CmmT_Name fs))
+  where
+	fs = lexemeToFastString buf len
+
+reservedWordsFM = listToUFM $
+	map (\(x, y) -> (mkFastString x, y)) [
+	( "CLOSURE",		CmmT_CLOSURE ),
+	( "INFO_TABLE",		CmmT_INFO_TABLE ),
+	( "INFO_TABLE_RET",	CmmT_INFO_TABLE_RET ),
+	( "INFO_TABLE_FUN",	CmmT_INFO_TABLE_FUN ),
+	( "INFO_TABLE_CONSTR",	CmmT_INFO_TABLE_CONSTR ),
+	( "INFO_TABLE_SELECTOR",CmmT_INFO_TABLE_SELECTOR ),
+	( "else",		CmmT_else ),
+	( "export",		CmmT_export ),
+	( "section",		CmmT_section ),
+	( "align",		CmmT_align ),
+	( "goto",		CmmT_goto ),
+	( "if",			CmmT_if ),
+	( "jump",		CmmT_jump ),
+	( "foreign",		CmmT_foreign ),
+	( "import",		CmmT_import ),
+	( "switch",		CmmT_switch ),
+	( "case",		CmmT_case ),
+	( "default",		CmmT_default ),
+	( "bits8",		CmmT_bits8 ),
+	( "bits16",		CmmT_bits16 ),
+	( "bits32",		CmmT_bits32 ),
+	( "bits64",		CmmT_bits64 ),
+	( "float32",		CmmT_float32 ),
+	( "float64",		CmmT_float64 )
+	]
+
+tok_decimal span buf len 
+  = return (L span (CmmT_Int  $! parseInteger buf len 10 octDecDigit))
+
+tok_octal span buf len 
+  = return (L span (CmmT_Int  $! parseInteger (offsetBytes 1 buf) (len-1) 8 octDecDigit))
+
+tok_hexadecimal span buf len 
+  = return (L span (CmmT_Int  $! parseInteger (offsetBytes 2 buf) (len-2) 16 hexDigit))
+
+tok_float str = CmmT_Float $! readRational str
+
+tok_string str = CmmT_String (read str)
+		 -- urk, not quite right, but it'll do for now
+
+-- -----------------------------------------------------------------------------
+-- Line pragmas
+
+setLine :: Int -> Action
+setLine code span buf len = do
+  let line = parseInteger buf len 10 octDecDigit
+  setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0)
+	-- subtract one: the line number refers to the *following* line
+  -- trace ("setLine "  ++ show line) $ do
+  popLexState
+  pushLexState code
+  lexToken
+
+setFile :: Int -> Action
+setFile code span buf len = do
+  let file = lexemeToFastString (stepOn buf) (len-2)
+  setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
+  popLexState
+  pushLexState code
+  lexToken
+
+-- -----------------------------------------------------------------------------
+-- This is the top-level function: called from the parser each time a
+-- new token is to be read from the input.
+
+cmmlex :: (Located CmmToken -> P a) -> P a
+cmmlex cont = do
+  tok@(L _ tok__) <- lexToken
+  --trace ("token: " ++ show tok__) $ do
+  cont tok
+
+lexToken :: P (Located CmmToken)
+lexToken = do
+  inp@(loc1,buf) <- getInput
+  sc <- getLexState
+  case alexScan inp sc of
+    AlexEOF -> do let span = mkSrcSpan loc1 loc1
+		  setLastToken span 0
+		  return (L span CmmT_EOF)
+    AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error"
+    AlexSkip inp2 _ -> do
+	setInput inp2
+	lexToken
+    AlexToken inp2@(end,buf2) len t -> do
+	setInput inp2
+	let span = mkSrcSpan loc1 end
+	span `seq` setLastToken span len
+	t span buf len
+
+-- -----------------------------------------------------------------------------
+-- Monad stuff
+
+-- Stuff that Alex needs to know about our input type:
+type AlexInput = (SrcLoc,StringBuffer)
+
+alexInputPrevChar :: AlexInput -> Char
+alexInputPrevChar (_,s) = prevChar s '\n'
+
+alexGetChar :: AlexInput -> Maybe (Char,AlexInput)
+alexGetChar (loc,s) 
+  | atEnd s   = Nothing
+  | otherwise = c `seq` loc' `seq` s' `seq` Just (c, (loc', s'))
+  where c = currentChar s
+        loc' = advanceSrcLoc loc c
+	s'   = stepOn s
+
+getInput :: P AlexInput
+getInput = P $ \s@PState{ loc=l, buffer=b } -> POk s (l,b)
+
+setInput :: AlexInput -> P ()
+setInput (l,b) = P $ \s -> POk s{ loc=l, buffer=b } ()
+}
diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
new file mode 100644
index 0000000000..fbfb14c165
--- /dev/null
+++ b/compiler/cmm/CmmLint.hs
@@ -0,0 +1,159 @@
+-----------------------------------------------------------------------------
+--
+-- CmmLint: checking the correctness of Cmm statements and expressions
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CmmLint (
+  cmmLint, cmmLintTop
+  ) where
+
+#include "HsVersions.h"
+
+import Cmm
+import CLabel		( pprCLabel )
+import MachOp
+import Outputable
+import PprCmm
+import Unique		( getUnique )
+import Constants	( wORD_SIZE )
+
+import Monad		( when )
+
+-- -----------------------------------------------------------------------------
+-- Exported entry points:
+
+cmmLint :: Cmm -> Maybe SDoc
+cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
+
+cmmLintTop :: CmmTop -> Maybe SDoc
+cmmLintTop top = runCmmLint $ lintCmmTop top
+
+runCmmLint :: CmmLint a -> Maybe SDoc
+runCmmLint l = 
+   case unCL l of
+	Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
+	Right _  -> Nothing
+
+lintCmmTop (CmmProc _info lbl _args blocks)
+  = addLintInfo (text "in proc " <> pprCLabel lbl) $
+	mapM_ lintCmmBlock blocks
+lintCmmTop _other
+  = return ()
+
+lintCmmBlock (BasicBlock id stmts)
+  = addLintInfo (text "in basic block " <> ppr (getUnique id)) $
+	mapM_ lintCmmStmt stmts
+
+-- -----------------------------------------------------------------------------
+-- lintCmmExpr
+
+-- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
+-- byte/word mismatches.
+
+lintCmmExpr :: CmmExpr -> CmmLint MachRep
+lintCmmExpr (CmmLoad expr rep) = do
+  lintCmmExpr expr
+  when (machRepByteWidth rep >= wORD_SIZE) $
+     cmmCheckWordAddress expr
+  return rep
+lintCmmExpr expr@(CmmMachOp op args) = do
+  mapM_ lintCmmExpr args
+  if map cmmExprRep args == machOpArgReps op
+  	then cmmCheckMachOp op args
+	else cmmLintMachOpErr expr
+lintCmmExpr (CmmRegOff reg offset)
+  = lintCmmExpr (CmmMachOp (MO_Add rep) 
+		[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
+  where rep = cmmRegRep reg
+lintCmmExpr lit@(CmmLit (CmmInt _ rep))
+  | isFloatingRep rep
+  = cmmLintErr (text "integer literal with floating MachRep: " <> ppr lit)
+lintCmmExpr expr = 
+  return (cmmExprRep expr)
+
+-- Check for some common byte/word mismatches (eg. Sp + 1)
+cmmCheckMachOp  op args@[CmmReg reg, CmmLit (CmmInt i _)]
+  | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
+  = cmmLintDubiousWordOffset (CmmMachOp op args)
+cmmCheckMachOp op [lit@(CmmLit (CmmInt i _)), reg@(CmmReg _)]
+  = cmmCheckMachOp op [reg, lit]
+cmmCheckMachOp op@(MO_U_Conv from to) args
+  | isFloatingRep from || isFloatingRep to
+  = cmmLintErr (text "unsigned conversion from/to floating rep: " 
+		<> ppr (CmmMachOp op args))
+cmmCheckMachOp op args
+  = return (resultRepOfMachOp op)
+
+isWordOffsetReg (CmmGlobal Sp) = True
+isWordOffsetReg (CmmGlobal Hp) = True
+isWordOffsetReg _ = False
+
+isOffsetOp (MO_Add _) = True
+isOffsetOp (MO_Sub _) = True
+isOffsetOp _ = False
+
+-- This expression should be an address from which a word can be loaded:
+-- check for funny-looking sub-word offsets.
+cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
+  | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
+  = cmmLintDubiousWordOffset e
+cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
+  | isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
+  = cmmLintDubiousWordOffset e
+cmmCheckWordAddress _
+  = return ()
+
+
+lintCmmStmt :: CmmStmt -> CmmLint ()
+lintCmmStmt stmt@(CmmAssign reg expr) = do
+  erep <- lintCmmExpr expr
+  if (erep == cmmRegRep reg)
+	then return ()
+	else cmmLintAssignErr stmt
+lintCmmStmt (CmmStore l r) = do
+  lintCmmExpr l
+  lintCmmExpr r
+  return ()
+lintCmmStmt (CmmCall _target _res args _vols) = mapM_ (lintCmmExpr.fst) args
+lintCmmStmt (CmmCondBranch e _id)   = lintCmmExpr e >> return ()
+lintCmmStmt (CmmSwitch e _branches) = lintCmmExpr e >> return ()
+lintCmmStmt (CmmJump e _args)       = lintCmmExpr e >> return ()
+lintCmmStmt _other 		    = return ()
+
+-- -----------------------------------------------------------------------------
+-- CmmLint monad
+
+-- just a basic error monad:
+
+newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
+
+instance Monad CmmLint where
+  CmmLint m >>= k = CmmLint $ case m of 
+				Left e -> Left e
+				Right a -> unCL (k a)
+  return a = CmmLint (Right a)
+
+cmmLintErr :: SDoc -> CmmLint a
+cmmLintErr msg = CmmLint (Left msg)
+
+addLintInfo :: SDoc -> CmmLint a -> CmmLint a
+addLintInfo info thing = CmmLint $ 
+   case unCL thing of
+	Left err -> Left (hang info 2 err)
+	Right a  -> Right a
+
+cmmLintMachOpErr :: CmmExpr -> CmmLint a
+cmmLintMachOpErr expr = cmmLintErr (text "in MachOp application: " $$ 
+					nest 2 (pprExpr expr))
+
+cmmLintAssignErr :: CmmStmt -> CmmLint a
+cmmLintAssignErr stmt = cmmLintErr (text "in assignment: " $$ 
+					nest 2 (pprStmt stmt))
+
+cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
+cmmLintDubiousWordOffset expr
+   = cmmLintErr (text "offset is not a multiple of words: " $$
+			nest 2 (pprExpr expr))
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
new file mode 100644
index 0000000000..c454ff4c6a
--- /dev/null
+++ b/compiler/cmm/CmmOpt.hs
@@ -0,0 +1,507 @@
+-----------------------------------------------------------------------------
+--
+-- Cmm optimisation
+--
+-- (c) The University of Glasgow 2006
+--
+-----------------------------------------------------------------------------
+
+module CmmOpt (
+	cmmMiniInline,
+	cmmMachOpFold,
+	cmmLoopifyForC,
+ ) where
+
+#include "HsVersions.h"
+
+import Cmm
+import CmmUtils	( hasNoGlobalRegs )
+import CLabel	( entryLblToInfoLbl )
+import MachOp
+import SMRep	( tablesNextToCode )
+
+import UniqFM
+import Unique	( Unique )
+import Panic	( panic )
+
+import Outputable
+
+import Bits
+import Word
+import Int
+import GLAEXTS
+
+
+-- -----------------------------------------------------------------------------
+-- The mini-inliner
+
+{-
+This pass inlines assignments to temporaries that are used just
+once.  It works as follows:
+
+  - count uses of each temporary
+  - for each temporary that occurs just once:
+	- attempt to push it forward to the statement that uses it
+        - only push forward past assignments to other temporaries
+	  (assumes that temporaries are single-assignment)
+	- if we reach the statement that uses it, inline the rhs
+	  and delete the original assignment.
+
+Possible generalisations: here is an example from factorial
+
+Fac_zdwfac_entry:
+    cmG:
+        _smi = R2;
+        if (_smi != 0) goto cmK;
+        R1 = R3;
+        jump I64[Sp];
+    cmK:
+        _smn = _smi * R3;
+        R2 = _smi + (-1);
+        R3 = _smn;
+        jump Fac_zdwfac_info;
+
+We want to inline _smi and _smn.  To inline _smn:
+
+   - we must be able to push forward past assignments to global regs.
+     We can do this if the rhs of the assignment we are pushing
+     forward doesn't refer to the global reg being assigned to; easy
+     to test.
+
+To inline _smi:
+
+   - It is a trivial replacement, reg for reg, but it occurs more than
+     once.
+   - We can inline trivial assignments even if the temporary occurs
+     more than once, as long as we don't eliminate the original assignment
+     (this doesn't help much on its own).
+   - We need to be able to propagate the assignment forward through jumps;
+     if we did this, we would find that it can be inlined safely in all
+     its occurrences.
+-}
+
+cmmMiniInline :: [CmmBasicBlock] -> [CmmBasicBlock]
+cmmMiniInline blocks = map do_inline blocks 
+  where 
+	blockUses (BasicBlock _ stmts)
+	 = foldr (plusUFM_C (+)) emptyUFM (map getStmtUses stmts)
+
+	uses = foldr (plusUFM_C (+)) emptyUFM (map blockUses blocks)
+
+	do_inline (BasicBlock id stmts)
+	 = BasicBlock id (cmmMiniInlineStmts uses stmts)
+
+
+cmmMiniInlineStmts :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
+cmmMiniInlineStmts uses [] = []
+cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
+  | Just 1 <- lookupUFM uses u,
+    Just stmts' <- lookForInline u expr stmts
+  = 
+#ifdef NCG_DEBUG
+     trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $
+#endif
+     cmmMiniInlineStmts uses stmts'
+
+cmmMiniInlineStmts uses (stmt:stmts)
+  = stmt : cmmMiniInlineStmts uses stmts
+
+
+-- Try to inline a temporary assignment.  We can skip over assignments to
+-- other tempoararies, because we know that expressions aren't side-effecting
+-- and temporaries are single-assignment.
+lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _)) rhs) : rest)
+  | u /= u' 
+  = case lookupUFM (getExprUses rhs) u of
+	Just 1 -> Just (inlineStmt u expr stmt : rest)
+	_other -> case lookForInline u expr rest of
+		     Nothing    -> Nothing
+		     Just stmts -> Just (stmt:stmts)
+
+lookForInline u expr (CmmNop : rest)
+  = lookForInline u expr rest
+
+lookForInline u expr (stmt:stmts)
+  = case lookupUFM (getStmtUses stmt) u of
+	Just 1 | ok_to_inline -> Just (inlineStmt u expr stmt : stmts)
+	_other -> Nothing
+  where
+	-- we don't inline into CmmCall if the expression refers to global
+	-- registers.  This is a HACK to avoid global registers clashing with
+	-- C argument-passing registers, really the back-end ought to be able
+	-- to handle it properly, but currently neither PprC nor the NCG can
+	-- do it.  See also CgForeignCall:load_args_into_temps.
+    ok_to_inline = case stmt of
+		     CmmCall{} -> hasNoGlobalRegs expr
+		     _ -> True
+
+-- -----------------------------------------------------------------------------
+-- Boring Cmm traversals for collecting usage info and substitutions.
+
+getStmtUses :: CmmStmt -> UniqFM Int
+getStmtUses (CmmAssign _ e) = getExprUses e
+getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2)
+getStmtUses (CmmCall target _ es _)
+   = plusUFM_C (+) (uses target) (getExprsUses (map fst es))
+   where uses (CmmForeignCall e _) = getExprUses e
+	 uses _ = emptyUFM
+getStmtUses (CmmCondBranch e _) = getExprUses e
+getStmtUses (CmmSwitch e _) = getExprUses e
+getStmtUses (CmmJump e _) = getExprUses e
+getStmtUses _ = emptyUFM
+
+getExprUses :: CmmExpr -> UniqFM Int
+getExprUses (CmmReg (CmmLocal (LocalReg u _))) = unitUFM u 1
+getExprUses (CmmRegOff (CmmLocal (LocalReg u _)) _) = unitUFM u 1
+getExprUses (CmmLoad e _) = getExprUses e
+getExprUses (CmmMachOp _ es) = getExprsUses es
+getExprUses _other = emptyUFM
+
+getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es)
+
+inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
+inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
+inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
+inlineStmt u a (CmmCall target regs es vols)
+   = CmmCall (infn target) regs es' vols
+   where infn (CmmForeignCall fn cconv) = CmmForeignCall fn cconv
+	 infn (CmmPrim p) = CmmPrim p
+	 es' = [ (inlineExpr u a e, hint) | (e,hint) <- es ]
+inlineStmt u a (CmmCondBranch e d) = CmmCondBranch (inlineExpr u a e) d
+inlineStmt u a (CmmSwitch e d) = CmmSwitch (inlineExpr u a e) d
+inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d
+inlineStmt u a other_stmt = other_stmt
+
+inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
+inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _)))
+  | u == u' = a
+  | otherwise = e
+inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
+  | u == u' = CmmMachOp (MO_Add rep) [a, CmmLit (CmmInt (fromIntegral off) rep)]
+  | otherwise = e
+inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep
+inlineExpr u a (CmmMachOp op es) = CmmMachOp op (map (inlineExpr u a) es)
+inlineExpr u a other_expr = other_expr
+
+-- -----------------------------------------------------------------------------
+-- MachOp constant folder
+
+-- Now, try to constant-fold the MachOps.  The arguments have already
+-- been optimized and folded.
+
+cmmMachOpFold
+    :: MachOp	    	-- The operation from an CmmMachOp
+    -> [CmmExpr]   	-- The optimized arguments
+    -> CmmExpr
+
+cmmMachOpFold op arg@[CmmLit (CmmInt x rep)]
+  = case op of
+      MO_S_Neg r -> CmmLit (CmmInt (-x) rep)
+      MO_Not r   -> CmmLit (CmmInt (complement x) rep)
+
+	-- these are interesting: we must first narrow to the 
+	-- "from" type, in order to truncate to the correct size.
+	-- The final narrow/widen to the destination type
+	-- is implicit in the CmmLit.
+      MO_S_Conv from to
+	   | isFloatingRep to -> CmmLit (CmmFloat (fromInteger x) to)
+	   | otherwise        -> CmmLit (CmmInt (narrowS from x) to)
+      MO_U_Conv from to -> CmmLit (CmmInt (narrowU from x) to)
+
+      _ -> panic "cmmMachOpFold: unknown unary op"
+
+
+-- Eliminate conversion NOPs
+cmmMachOpFold (MO_S_Conv rep1 rep2) [x] | rep1 == rep2 = x
+cmmMachOpFold (MO_U_Conv rep1 rep2) [x] | rep1 == rep2 = x
+
+-- Eliminate nested conversions where possible
+cmmMachOpFold conv_outer args@[CmmMachOp conv_inner [x]]
+  | Just (rep1,rep2,signed1) <- isIntConversion conv_inner,
+    Just (_,   rep3,signed2) <- isIntConversion conv_outer
+  = case () of
+	-- widen then narrow to the same size is a nop
+      _ | rep1 < rep2 && rep1 == rep3 -> x
+	-- Widen then narrow to different size: collapse to single conversion
+	-- but remember to use the signedness from the widening, just in case
+	-- the final conversion is a widen.
+	| rep1 < rep2 && rep2 > rep3 ->
+	    cmmMachOpFold (intconv signed1 rep1 rep3) [x]
+	-- Nested widenings: collapse if the signedness is the same
+	| rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->
+	    cmmMachOpFold (intconv signed1 rep1 rep3) [x]
+	-- Nested narrowings: collapse
+	| rep1 > rep2 && rep2 > rep3 ->
+	    cmmMachOpFold (MO_U_Conv rep1 rep3) [x]
+	| otherwise ->
+	    CmmMachOp conv_outer args
+  where
+	isIntConversion (MO_U_Conv rep1 rep2) 
+	  | not (isFloatingRep rep1) && not (isFloatingRep rep2) 
+	  = Just (rep1,rep2,False)
+	isIntConversion (MO_S_Conv rep1 rep2)
+	  | not (isFloatingRep rep1) && not (isFloatingRep rep2) 
+	  = Just (rep1,rep2,True)
+	isIntConversion _ = Nothing
+
+	intconv True  = MO_S_Conv
+	intconv False = MO_U_Conv
+
+-- ToDo: a narrow of a load can be collapsed into a narrow load, right?
+-- but what if the architecture only supports word-sized loads, should
+-- we do the transformation anyway?
+
+cmmMachOpFold mop args@[CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
+  = case mop of
+	-- for comparisons: don't forget to narrow the arguments before
+	-- comparing, since they might be out of range.
+    	MO_Eq r   -> CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordRep)
+    	MO_Ne r   -> CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordRep)
+
+    	MO_U_Gt r -> CmmLit (CmmInt (if x_u >  y_u then 1 else 0) wordRep)
+    	MO_U_Ge r -> CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordRep)
+    	MO_U_Lt r -> CmmLit (CmmInt (if x_u <  y_u then 1 else 0) wordRep)
+    	MO_U_Le r -> CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordRep)
+
+    	MO_S_Gt r -> CmmLit (CmmInt (if x_s >  y_s then 1 else 0) wordRep) 
+    	MO_S_Ge r -> CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordRep)
+    	MO_S_Lt r -> CmmLit (CmmInt (if x_s <  y_s then 1 else 0) wordRep)
+    	MO_S_Le r -> CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordRep)
+
+    	MO_Add r -> CmmLit (CmmInt (x + y) r)
+    	MO_Sub r -> CmmLit (CmmInt (x - y) r)
+    	MO_Mul r -> CmmLit (CmmInt (x * y) r)
+    	MO_S_Quot r | y /= 0 -> CmmLit (CmmInt (x `quot` y) r)
+    	MO_S_Rem  r | y /= 0 -> CmmLit (CmmInt (x `rem` y) r)
+
+	MO_And   r -> CmmLit (CmmInt (x .&. y) r)
+	MO_Or    r -> CmmLit (CmmInt (x .|. y) r)
+	MO_Xor   r -> CmmLit (CmmInt (x `xor` y) r)
+
+        MO_Shl   r -> CmmLit (CmmInt (x `shiftL` fromIntegral y) r)
+        MO_U_Shr r -> CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r)
+        MO_S_Shr r -> CmmLit (CmmInt (x `shiftR` fromIntegral y) r)
+
+	other      -> CmmMachOp mop args
+
+   where
+	x_u = narrowU xrep x
+	y_u = narrowU xrep y
+	x_s = narrowS xrep x
+	y_s = narrowS xrep y
+	
+
+-- When possible, shift the constants to the right-hand side, so that we
+-- can match for strength reductions.  Note that the code generator will
+-- also assume that constants have been shifted to the right when
+-- possible.
+
+cmmMachOpFold op [x@(CmmLit _), y]
+   | not (isLit y) && isCommutableMachOp op 
+   = cmmMachOpFold op [y, x]
+
+-- Turn (a+b)+c into a+(b+c) where possible.  Because literals are
+-- moved to the right, it is more likely that we will find
+-- opportunities for constant folding when the expression is
+-- right-associated.
+--
+-- ToDo: this appears to introduce a quadratic behaviour due to the
+-- nested cmmMachOpFold.  Can we fix this?
+--
+-- Why do we check isLit arg1?  If arg1 is a lit, it means that arg2
+-- is also a lit (otherwise arg1 would be on the right).  If we
+-- put arg1 on the left of the rearranged expression, we'll get into a
+-- loop:  (x1+x2)+x3 => x1+(x2+x3)  => (x2+x3)+x1 => x2+(x3+x1) ...
+--
+cmmMachOpFold mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
+   | mop1 == mop2 && isAssociativeMachOp mop1 && not (isLit arg1)
+   = cmmMachOpFold mop1 [arg1, cmmMachOpFold mop2 [arg2,arg3]]
+
+-- Make a RegOff if we can
+cmmMachOpFold (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
+  = CmmRegOff reg (fromIntegral (narrowS rep n))
+cmmMachOpFold (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
+  = CmmRegOff reg (off + fromIntegral (narrowS rep n))
+cmmMachOpFold (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]
+  = CmmRegOff reg (- fromIntegral (narrowS rep n))
+cmmMachOpFold (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
+  = CmmRegOff reg (off - fromIntegral (narrowS rep n))
+
+-- Fold label(+/-)offset into a CmmLit where possible
+
+cmmMachOpFold (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
+  = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
+cmmMachOpFold (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)]
+  = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
+cmmMachOpFold (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
+  = CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i))))
+
+-- We can often do something with constants of 0 and 1 ...
+
+cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))]
+  = case mop of
+    	MO_Add   r -> x
+    	MO_Sub   r -> x
+    	MO_Mul   r -> y
+    	MO_And   r -> y
+    	MO_Or    r -> x
+    	MO_Xor   r -> x
+    	MO_Shl   r -> x
+    	MO_S_Shr r -> x
+    	MO_U_Shr r -> x
+        MO_Ne    r | isComparisonExpr x -> x
+	MO_Eq    r | Just x' <- maybeInvertConditionalExpr x -> x'
+	MO_U_Gt  r | isComparisonExpr x -> x
+	MO_S_Gt  r | isComparisonExpr x -> x
+	MO_U_Lt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
+	MO_S_Lt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
+	MO_U_Ge  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
+	MO_S_Ge  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
+	MO_U_Le  r | Just x' <- maybeInvertConditionalExpr x -> x'
+	MO_S_Le  r | Just x' <- maybeInvertConditionalExpr x -> x'
+    	other    -> CmmMachOp mop args
+
+cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))]
+  = case mop of
+    	MO_Mul    r -> x
+    	MO_S_Quot r -> x
+    	MO_U_Quot r -> x
+    	MO_S_Rem  r -> CmmLit (CmmInt 0 rep)
+    	MO_U_Rem  r -> CmmLit (CmmInt 0 rep)
+        MO_Ne    r | Just x' <- maybeInvertConditionalExpr x -> x'
+	MO_Eq    r | isComparisonExpr x -> x
+	MO_U_Lt  r | Just x' <- maybeInvertConditionalExpr x -> x'
+	MO_S_Lt  r | Just x' <- maybeInvertConditionalExpr x -> x'
+	MO_U_Gt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
+	MO_S_Gt  r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
+	MO_U_Le  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
+	MO_S_Le  r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
+	MO_U_Ge  r | isComparisonExpr x -> x
+	MO_S_Ge  r | isComparisonExpr x -> x
+    	other       -> CmmMachOp mop args
+
+-- Now look for multiplication/division by powers of 2 (integers).
+
+cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt n _))]
+  = case mop of
+    	MO_Mul rep
+           -> case exactLog2 n of
+                 Nothing -> unchanged
+                 Just p  -> CmmMachOp (MO_Shl rep) [x, CmmLit (CmmInt p rep)]
+    	MO_S_Quot rep
+           -> case exactLog2 n of
+                 Nothing -> unchanged
+                 Just p  -> CmmMachOp (MO_S_Shr rep) [x, CmmLit (CmmInt p rep)]
+    	other 
+           -> unchanged
+    where
+       unchanged = CmmMachOp mop args
+
+-- Anything else is just too hard.
+
+cmmMachOpFold mop args = CmmMachOp mop args
+
+-- -----------------------------------------------------------------------------
+-- exactLog2
+
+-- This algorithm for determining the $\log_2$ of exact powers of 2 comes
+-- from GCC.  It requires bit manipulation primitives, and we use GHC
+-- extensions.  Tough.
+-- 
+-- Used to be in MachInstrs --SDM.
+-- ToDo: remove use of unboxery --SDM.
+
+w2i x = word2Int# x
+i2w x = int2Word# x
+
+exactLog2 :: Integer -> Maybe Integer
+exactLog2 x
+  = if (x <= 0 || x >= 2147483648) then
+       Nothing
+    else
+       case fromInteger x of { I# x# ->
+       if (w2i ((i2w x#) `and#` (i2w (0# -# x#))) /=# x#) then
+	  Nothing
+       else
+	  Just (toInteger (I# (pow2 x#)))
+       }
+  where
+    pow2 x# | x# ==# 1# = 0#
+            | otherwise = 1# +# pow2 (w2i (i2w x# `shiftRL#` 1#))
+
+
+-- -----------------------------------------------------------------------------
+-- widening / narrowing
+
+narrowU :: MachRep -> Integer -> Integer
+narrowU I8  x = fromIntegral (fromIntegral x :: Word8)
+narrowU I16 x = fromIntegral (fromIntegral x :: Word16)
+narrowU I32 x = fromIntegral (fromIntegral x :: Word32)
+narrowU I64 x = fromIntegral (fromIntegral x :: Word64)
+narrowU _ _ = panic "narrowTo"
+
+narrowS :: MachRep -> Integer -> Integer
+narrowS I8  x = fromIntegral (fromIntegral x :: Int8)
+narrowS I16 x = fromIntegral (fromIntegral x :: Int16)
+narrowS I32 x = fromIntegral (fromIntegral x :: Int32)
+narrowS I64 x = fromIntegral (fromIntegral x :: Int64)
+narrowS _ _ = panic "narrowTo"
+
+-- -----------------------------------------------------------------------------
+-- Loopify for C
+
+{-
+ This is a simple pass that replaces tail-recursive functions like this:
+
+   fac() {
+     ...
+     jump fac();
+   }
+
+ with this:
+
+  fac() {
+   L:
+     ...
+     goto L;
+  }
+
+  the latter generates better C code, because the C compiler treats it
+  like a loop, and brings full loop optimisation to bear.
+
+  In my measurements this makes little or no difference to anything
+  except factorial, but what the hell.
+-}
+
+cmmLoopifyForC :: CmmTop -> CmmTop
+cmmLoopifyForC p@(CmmProc info entry_lbl [] blocks@(BasicBlock top_id _ : _))
+  | null info = p  -- only if there's an info table, ignore case alts
+  | otherwise =  
+--  pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $
+  CmmProc info entry_lbl [] blocks' 
+  where blocks' = [ BasicBlock id (map do_stmt stmts)
+		  | BasicBlock id stmts <- blocks ]
+
+        do_stmt (CmmJump (CmmLit (CmmLabel lbl)) _) | lbl == jump_lbl
+		= CmmBranch top_id
+	do_stmt stmt = stmt
+
+	jump_lbl | tablesNextToCode = entryLblToInfoLbl entry_lbl
+		 | otherwise        = entry_lbl
+
+cmmLoopifyForC top = top
+
+-- -----------------------------------------------------------------------------
+-- Utils
+
+isLit (CmmLit _) = True
+isLit _          = False
+
+isComparisonExpr :: CmmExpr -> Bool
+isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
+isComparisonExpr _other 	    = False
+
+maybeInvertConditionalExpr :: CmmExpr -> Maybe CmmExpr
+maybeInvertConditionalExpr (CmmMachOp op args) 
+  | Just op' <- maybeInvertComparison op = Just (CmmMachOp op' args)
+maybeInvertConditionalExpr _ = Nothing
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
new file mode 100644
index 0000000000..73618bc35b
--- /dev/null
+++ b/compiler/cmm/CmmParse.y
@@ -0,0 +1,890 @@
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow, 2004
+--
+-- Parser for concrete Cmm.
+--
+-----------------------------------------------------------------------------
+
+{
+module CmmParse ( parseCmmFile ) where
+
+import CgMonad
+import CgHeapery
+import CgUtils
+import CgProf
+import CgTicky
+import CgInfoTbls
+import CgForeignCall
+import CgTailCall	( pushUnboxedTuple )
+import CgStackery	( emitPushUpdateFrame )
+import ClosureInfo	( C_SRT(..) )
+import CgCallConv	( smallLiveness )
+import CgClosure	( emitBlackHoleCode )
+import CostCentre	( dontCareCCS )
+
+import Cmm
+import PprCmm
+import CmmUtils		( mkIntCLit )
+import CmmLex
+import CLabel
+import MachOp
+import SMRep		( fixedHdrSize, CgRep(..) )
+import Lexer
+
+import ForeignCall	( CCallConv(..), Safety(..) )
+import Literal		( mkMachInt )
+import Unique
+import UniqFM
+import SrcLoc
+import DynFlags		( DynFlags, DynFlag(..) )
+import Packages		( HomeModules )
+import StaticFlags	( opt_SccProfilingOn )
+import ErrUtils		( printError, dumpIfSet_dyn, showPass )
+import StringBuffer	( hGetStringBuffer )
+import FastString
+import Panic		( panic )
+import Constants	( wORD_SIZE )
+import Outputable
+
+import Monad		( when )
+import Data.Char	( ord )
+
+#include "HsVersions.h"
+}
+
+%token
+	':'	{ L _ (CmmT_SpecChar ':') }
+	';'	{ L _ (CmmT_SpecChar ';') }
+	'{'	{ L _ (CmmT_SpecChar '{') }
+	'}'	{ L _ (CmmT_SpecChar '}') }
+	'['	{ L _ (CmmT_SpecChar '[') }
+	']'	{ L _ (CmmT_SpecChar ']') }
+	'('	{ L _ (CmmT_SpecChar '(') }
+	')'	{ L _ (CmmT_SpecChar ')') }
+	'='	{ L _ (CmmT_SpecChar '=') }
+	'`'	{ L _ (CmmT_SpecChar '`') }
+	'~'	{ L _ (CmmT_SpecChar '~') }
+	'/'	{ L _ (CmmT_SpecChar '/') }
+	'*'	{ L _ (CmmT_SpecChar '*') }
+	'%'	{ L _ (CmmT_SpecChar '%') }
+	'-'	{ L _ (CmmT_SpecChar '-') }
+	'+'	{ L _ (CmmT_SpecChar '+') }
+	'&'	{ L _ (CmmT_SpecChar '&') }
+	'^'	{ L _ (CmmT_SpecChar '^') }
+	'|'	{ L _ (CmmT_SpecChar '|') }
+	'>'	{ L _ (CmmT_SpecChar '>') }
+	'<'	{ L _ (CmmT_SpecChar '<') }
+	','	{ L _ (CmmT_SpecChar ',') }
+	'!'	{ L _ (CmmT_SpecChar '!') }
+
+ 	'..'	{ L _ (CmmT_DotDot) }
+ 	'::'	{ L _ (CmmT_DoubleColon) }
+	'>>'	{ L _ (CmmT_Shr) }
+	'<<'	{ L _ (CmmT_Shl) }
+	'>='	{ L _ (CmmT_Ge) }
+	'<='	{ L _ (CmmT_Le) }
+	'=='	{ L _ (CmmT_Eq) }
+	'!='	{ L _ (CmmT_Ne) }
+        '&&'    { L _ (CmmT_BoolAnd) }
+        '||'    { L _ (CmmT_BoolOr) }
+
+	'CLOSURE'	{ L _ (CmmT_CLOSURE) }
+	'INFO_TABLE'	{ L _ (CmmT_INFO_TABLE) }
+	'INFO_TABLE_RET'{ L _ (CmmT_INFO_TABLE_RET) }
+	'INFO_TABLE_FUN'{ L _ (CmmT_INFO_TABLE_FUN) }
+	'INFO_TABLE_CONSTR'{ L _ (CmmT_INFO_TABLE_CONSTR) }
+	'INFO_TABLE_SELECTOR'{ L _ (CmmT_INFO_TABLE_SELECTOR) }
+	'else'		{ L _ (CmmT_else) }
+	'export'	{ L _ (CmmT_export) }
+	'section'	{ L _ (CmmT_section) }
+	'align'		{ L _ (CmmT_align) }
+	'goto'		{ L _ (CmmT_goto) }
+	'if'		{ L _ (CmmT_if) }
+	'jump'		{ L _ (CmmT_jump) }
+	'foreign'	{ L _ (CmmT_foreign) }
+	'import'	{ L _ (CmmT_import) }
+	'switch'	{ L _ (CmmT_switch) }
+	'case'		{ L _ (CmmT_case) }
+	'default'	{ L _ (CmmT_default) }
+	'bits8'		{ L _ (CmmT_bits8) }
+	'bits16'	{ L _ (CmmT_bits16) }
+	'bits32'	{ L _ (CmmT_bits32) }
+	'bits64'	{ L _ (CmmT_bits64) }
+	'float32'	{ L _ (CmmT_float32) }
+	'float64'	{ L _ (CmmT_float64) }
+
+	GLOBALREG	{ L _ (CmmT_GlobalReg   $$) }
+  	NAME		{ L _ (CmmT_Name	$$) }
+	STRING		{ L _ (CmmT_String	$$) }
+	INT		{ L _ (CmmT_Int		$$) }
+	FLOAT		{ L _ (CmmT_Float	$$) }
+
+%monad { P } { >>= } { return }
+%lexer { cmmlex } { L _ CmmT_EOF }
+%name cmmParse cmm
+%tokentype { Located CmmToken }
+
+-- C-- operator precedences, taken from the C-- spec
+%right '||'	-- non-std extension, called %disjoin in C--
+%right '&&'	-- non-std extension, called %conjoin in C--
+%right '!'
+%nonassoc '>=' '>' '<=' '<' '!=' '=='
+%left '|'
+%left '^'
+%left '&'
+%left '>>' '<<'
+%left '-' '+'
+%left '/' '*' '%'
+%right '~'
+
+%%
+
+cmm	:: { ExtCode }
+	: {- empty -}			{ return () }
+	| cmmtop cmm			{ do $1; $2 }
+
+cmmtop	:: { ExtCode }
+	: cmmproc			{ $1 }
+	| cmmdata			{ $1 }
+	| decl				{ $1 } 
+	| 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
+		{ do lits <- sequence $6;
+		     staticClosure $3 $5 (map getLit lits) }
+
+-- The only static closures in the RTS are dummy closures like
+-- stg_END_TSO_QUEUE_closure and stg_dummy_ret.  We don't need
+-- to provide the full generality of static closures here.
+-- In particular:
+-- 	* CCS can always be CCS_DONT_CARE
+-- 	* closure is always extern
+-- 	* payload is always empty
+--	* we can derive closure and info table labels from a single NAME
+
+cmmdata :: { ExtCode }
+	: 'section' STRING '{' statics '}' 
+		{ do ss <- sequence $4;
+		     code (emitData (section $2) (concat ss)) }
+
+statics	:: { [ExtFCode [CmmStatic]] }
+	: {- empty -}			{ [] }
+	| static statics		{ $1 : $2 }
+
+-- Strings aren't used much in the RTS HC code, so it doesn't seem
+-- worth allowing inline strings.  C-- doesn't allow them anyway.
+static 	:: { ExtFCode [CmmStatic] }
+	: NAME ':'	{ return [CmmDataLabel (mkRtsDataLabelFS $1)] }
+	| type expr ';'	{ do e <- $2;
+			     return [CmmStaticLit (getLit e)] }
+	| type ';'			{ return [CmmUninitialised
+							(machRepByteWidth $1)] }
+        | 'bits8' '[' ']' STRING ';'	{ return [mkString $4] }
+        | 'bits8' '[' INT ']' ';'	{ return [CmmUninitialised 
+							(fromIntegral $3)] }
+        | typenot8 '[' INT ']' ';'	{ return [CmmUninitialised 
+						(machRepByteWidth $1 * 
+							fromIntegral $3)] }
+	| 'align' INT ';'		{ return [CmmAlign (fromIntegral $2)] }
+	| 'CLOSURE' '(' NAME lits ')'
+		{ do lits <- sequence $4;
+		     return $ map CmmStaticLit $
+		       mkStaticClosure (mkRtsInfoLabelFS $3) 
+			 dontCareCCS (map getLit lits) [] [] [] }
+	-- arrays of closures required for the CHARLIKE & INTLIKE arrays
+
+lits	:: { [ExtFCode CmmExpr] }
+	: {- empty -}		{ [] }
+	| ',' expr lits		{ $2 : $3 }
+
+cmmproc :: { ExtCode }
+	: info '{' body '}'
+		{ do  (info_lbl, info1, info2) <- $1;
+		      stmts <- getCgStmtsEC (loopDecls $3)
+		      blks <- code (cgStmtsToBlocks stmts)
+		      code (emitInfoTableAndCode info_lbl info1 info2 [] blks) }
+
+	| info ';'
+		{ do (info_lbl, info1, info2) <- $1;
+		     code (emitInfoTableAndCode info_lbl info1 info2 [] []) }
+
+	| NAME '{' body '}'
+		{ do stmts <- getCgStmtsEC (loopDecls $3);
+		     blks <- code (cgStmtsToBlocks stmts)
+		     code (emitProc [] (mkRtsCodeLabelFS $1) [] blks) }
+
+info	:: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
+	: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
+		-- ptrs, nptrs, closure type, description, type
+		{ stdInfo $3 $5 $7 0 $9 $11 $13 }
+	
+	| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
+		-- ptrs, nptrs, closure type, description, type, fun type
+		{ funInfo $3 $5 $7 $9 $11 $13 $15 }
+	
+	| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
+		-- ptrs, nptrs, tag, closure type, description, type
+		{ stdInfo $3 $5 $7 $9 $11 $13 $15 }
+	
+	| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
+		-- selector, closure type, description, type
+		{ basicInfo $3 (mkIntCLit (fromIntegral $5)) 0 $7 $9 $11 }
+
+	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' INT ',' INT maybe_vec ')'
+		{ retInfo $3 $5 $7 $9 $10 }
+
+maybe_vec :: { [CmmLit] }
+	: {- empty -}			{ [] }
+	| ',' NAME maybe_vec		{ CmmLabel (mkRtsCodeLabelFS $2) : $3 }
+
+body	:: { ExtCode }
+	: {- empty -}			{ return () }
+	| decl body			{ do $1; $2 }
+	| stmt body			{ do $1; $2 }
+
+decl	:: { ExtCode }
+	: type names ';'		{ mapM_ (newLocal $1) $2 }
+	| 'import' names ';'		{ return () }  -- ignore imports
+	| 'export' names ';'		{ return () }  -- ignore exports
+
+names 	:: { [FastString] }
+	: NAME			{ [$1] }
+	| NAME ',' names	{ $1 : $3 }
+
+stmt	:: { ExtCode }
+	: ';'					{ nopEC }
+
+	| block_id ':'				{ code (labelC $1) }
+
+	| lreg '=' expr ';'			
+		{ do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
+	| type '[' expr ']' '=' expr ';'
+		{ doStore $1 $3 $6 }
+	| 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
+		{% foreignCall $2 [] $3 $5 $7 }
+	| lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
+		{% let result = do r <- $1; return (r,NoHint) in
+		   foreignCall $4 [result] $5 $7 $9 }
+	| STRING lreg '=' 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
+		{% do h <- parseHint $1;
+		      let result = do r <- $2; return (r,h) in
+		      foreignCall $5 [result] $6 $8 $10 }
+	-- stmt-level macros, stealing syntax from ordinary C-- function calls.
+	-- Perhaps we ought to use the %%-form?
+	| NAME '(' exprs0 ')' ';'
+		{% stmtMacro $1 $3  }
+	| 'switch' maybe_range expr '{' arms default '}'
+		{ doSwitch $2 $3 $5 $6 }
+	| 'goto' block_id ';'
+		{ stmtEC (CmmBranch $2) }
+	| 'jump' expr {-maybe_actuals-} ';'
+		{ do e <- $2; stmtEC (CmmJump e []) }
+	| 'if' bool_expr '{' body '}' else 	
+		{ ifThenElse $2 $4 $6 }
+
+bool_expr :: { ExtFCode BoolExpr }
+	: bool_op			{ $1 }
+	| expr				{ do e <- $1; return (BoolTest e) }
+
+bool_op :: { ExtFCode BoolExpr }
+	: bool_expr '&&' bool_expr 	{ do e1 <- $1; e2 <- $3; 
+					  return (BoolAnd e1 e2) }
+	| bool_expr '||' bool_expr	{ do e1 <- $1; e2 <- $3; 
+					  return (BoolOr e1 e2)  }
+	| '!' bool_expr			{ do e <- $2; return (BoolNot e) }
+	| '(' bool_op ')'		{ $2 }
+
+-- This is not C-- syntax.  What to do?
+vols 	:: { Maybe [GlobalReg] }
+	: {- empty -}			{ Nothing }
+	| '[' ']'		        { Just [] }
+	| '[' globals ']'		{ Just $2 }
+
+globals :: { [GlobalReg] }
+	: GLOBALREG			{ [$1] }
+	| GLOBALREG ',' globals		{ $1 : $3 }
+
+maybe_range :: { Maybe (Int,Int) }
+	: '[' INT '..' INT ']'	{ Just (fromIntegral $2, fromIntegral $4) }
+	| {- empty -}		{ Nothing }
+
+arms	:: { [([Int],ExtCode)] }
+	: {- empty -}			{ [] }
+	| arm arms			{ $1 : $2 }
+
+arm	:: { ([Int],ExtCode) }
+	: 'case' ints ':' '{' body '}'	{ ($2, $5) }
+
+ints	:: { [Int] }
+	: INT				{ [ fromIntegral $1 ] }
+	| INT ',' ints			{ fromIntegral $1 : $3 }
+
+default :: { Maybe ExtCode }
+	: 'default' ':' '{' body '}'	{ Just $4 }
+	-- taking a few liberties with the C-- syntax here; C-- doesn't have
+	-- 'default' branches
+	| {- empty -}			{ Nothing }
+
+else 	:: { ExtCode }
+	: {- empty -}			{ nopEC }
+	| 'else' '{' body '}'		{ $3 }
+
+-- we have to write this out longhand so that Happy's precedence rules
+-- can kick in.
+expr	:: { ExtFCode CmmExpr } 
+	: expr '/' expr			{ mkMachOp MO_U_Quot [$1,$3] }
+	| expr '*' expr			{ mkMachOp MO_Mul [$1,$3] }
+	| expr '%' expr			{ mkMachOp MO_U_Rem [$1,$3] }
+	| expr '-' expr			{ mkMachOp MO_Sub [$1,$3] }
+	| expr '+' expr			{ mkMachOp MO_Add [$1,$3] }
+	| expr '>>' expr		{ mkMachOp MO_U_Shr [$1,$3] }
+	| expr '<<' expr		{ mkMachOp MO_Shl [$1,$3] }
+	| expr '&' expr			{ mkMachOp MO_And [$1,$3] }
+	| expr '^' expr			{ mkMachOp MO_Xor [$1,$3] }
+	| expr '|' expr			{ mkMachOp MO_Or [$1,$3] }
+	| expr '>=' expr		{ mkMachOp MO_U_Ge [$1,$3] }
+	| expr '>' expr			{ mkMachOp MO_U_Gt [$1,$3] }
+	| expr '<=' expr		{ mkMachOp MO_U_Le [$1,$3] }
+	| expr '<' expr			{ mkMachOp MO_U_Lt [$1,$3] }
+	| expr '!=' expr		{ mkMachOp MO_Ne [$1,$3] }
+	| expr '==' expr		{ mkMachOp MO_Eq [$1,$3] }
+	| '~' expr			{ mkMachOp MO_Not [$2] }
+	| '-' expr			{ mkMachOp MO_S_Neg [$2] }
+	| expr0 '`' NAME '`' expr0  	{% do { mo <- nameToMachOp $3 ;
+					        return (mkMachOp mo [$1,$5]) } }
+	| expr0				{ $1 }
+
+expr0	:: { ExtFCode CmmExpr }
+	: INT   maybe_ty	 { return (CmmLit (CmmInt $1 $2)) }
+	| FLOAT maybe_ty	 { return (CmmLit (CmmFloat $1 $2)) }
+	| STRING		 { do s <- code (mkStringCLit $1); 
+				      return (CmmLit s) }
+	| reg			 { $1 }
+	| type '[' expr ']'	 { do e <- $3; return (CmmLoad e $1) }
+	| '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
+	| '(' expr ')'		 { $2 }
+
+
+-- leaving out the type of a literal gives you the native word size in C--
+maybe_ty :: { MachRep }
+	: {- empty -}			{ wordRep }
+	| '::' type			{ $2 }
+
+hint_exprs0 :: { [ExtFCode (CmmExpr, MachHint)] }
+	: {- empty -}			{ [] }
+	| hint_exprs			{ $1 }
+
+hint_exprs :: { [ExtFCode (CmmExpr, MachHint)] }
+	: hint_expr			{ [$1] }
+	| hint_expr ',' hint_exprs	{ $1 : $3 }
+
+hint_expr :: { ExtFCode (CmmExpr, MachHint) }
+	: expr				{ do e <- $1; return (e, inferHint e) }
+	| expr STRING			{% do h <- parseHint $2;
+					      return $ do
+						e <- $1; return (e,h) }
+
+exprs0  :: { [ExtFCode CmmExpr] }
+	: {- empty -}			{ [] }
+	| exprs				{ $1 }
+
+exprs	:: { [ExtFCode CmmExpr] }
+	: expr				{ [ $1 ] }
+	| expr ',' exprs		{ $1 : $3 }
+
+reg	:: { ExtFCode CmmExpr }
+	: NAME			{ lookupName $1 }
+	| GLOBALREG		{ return (CmmReg (CmmGlobal $1)) }
+
+lreg	:: { ExtFCode CmmReg }
+	: NAME			{ do e <- lookupName $1;
+				     return $
+				       case e of 
+					CmmReg r -> r
+					other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
+	| GLOBALREG		{ return (CmmGlobal $1) }
+
+block_id :: { BlockId }
+	: NAME			{ BlockId (newTagUnique (getUnique $1) 'L') }
+			-- TODO: ugh.  The unique of a FastString has a null
+			-- tag, so we have to put our own tag on.  We should
+			-- really make a new unique for every label, and keep
+			-- them in an environment.
+
+type	:: { MachRep }
+	: 'bits8'		{ I8 }
+	| typenot8		{ $1 }
+
+typenot8 :: { MachRep }
+	: 'bits16'		{ I16 }
+	| 'bits32'		{ I32 }
+	| 'bits64'		{ I64 }
+	| 'float32'		{ F32 }
+	| 'float64'		{ F64 }
+{
+section :: String -> Section
+section "text"	 = Text
+section "data" 	 = Data
+section "rodata" = ReadOnlyData
+section "bss"	 = UninitialisedData
+section s	 = OtherSection s
+
+mkString :: String -> CmmStatic
+mkString s = CmmString (map (fromIntegral.ord) s)
+
+-- mkMachOp infers the type of the MachOp from the type of its first
+-- argument.  We assume that this is correct: for MachOps that don't have
+-- symmetrical args (e.g. shift ops), the first arg determines the type of
+-- the op.
+mkMachOp :: (MachRep -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
+mkMachOp fn args = do
+  arg_exprs <- sequence args
+  return (CmmMachOp (fn (cmmExprRep (head arg_exprs))) arg_exprs)
+
+getLit :: CmmExpr -> CmmLit
+getLit (CmmLit l) = l
+getLit (CmmMachOp (MO_S_Neg _) [CmmLit (CmmInt i r)])  = CmmInt (negate i) r
+getLit _ = panic "invalid literal" -- TODO messy failure
+
+nameToMachOp :: FastString -> P (MachRep -> MachOp)
+nameToMachOp name = 
+  case lookupUFM machOps name of
+	Nothing -> fail ("unknown primitive " ++ unpackFS name)
+	Just m  -> return m
+
+exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
+exprOp name args_code =
+  case lookupUFM exprMacros name of
+     Just f  -> return $ do
+        args <- sequence args_code
+	return (f args)
+     Nothing -> do
+	mo <- nameToMachOp name
+	return $ mkMachOp mo args_code
+
+exprMacros :: UniqFM ([CmmExpr] -> CmmExpr)
+exprMacros = listToUFM [
+  ( FSLIT("ENTRY_CODE"),   \ [x] -> entryCode x ),
+  ( FSLIT("INFO_PTR"),     \ [x] -> closureInfoPtr x ),
+  ( FSLIT("STD_INFO"),     \ [x] -> infoTable x ),
+  ( FSLIT("FUN_INFO"),     \ [x] -> funInfoTable x ),
+  ( FSLIT("GET_ENTRY"),    \ [x] -> entryCode (closureInfoPtr x) ),
+  ( FSLIT("GET_STD_INFO"), \ [x] -> infoTable (closureInfoPtr x) ),
+  ( FSLIT("GET_FUN_INFO"), \ [x] -> funInfoTable (closureInfoPtr x) ),
+  ( FSLIT("INFO_TYPE"),    \ [x] -> infoTableClosureType x ),
+  ( FSLIT("INFO_PTRS"),    \ [x] -> infoTablePtrs x ),
+  ( FSLIT("INFO_NPTRS"),   \ [x] -> infoTableNonPtrs x ),
+  ( FSLIT("RET_VEC"),      \ [info, conZ] -> retVec info conZ )
+  ]
+
+-- we understand a subset of C-- primitives:
+machOps = listToUFM $
+	map (\(x, y) -> (mkFastString x, y)) [
+	( "add",	MO_Add ),
+	( "sub",	MO_Sub ),
+	( "eq",		MO_Eq ),
+	( "ne",		MO_Ne ),
+	( "mul",	MO_Mul ),
+	( "neg",	MO_S_Neg ),
+	( "quot",	MO_S_Quot ),
+	( "rem",	MO_S_Rem ),
+	( "divu",	MO_U_Quot ),
+	( "modu",	MO_U_Rem ),
+
+	( "ge",		MO_S_Ge ),
+	( "le",		MO_S_Le ),
+	( "gt",		MO_S_Gt ),
+	( "lt",		MO_S_Lt ),
+
+	( "geu",	MO_U_Ge ),
+	( "leu",	MO_U_Le ),
+	( "gtu",	MO_U_Gt ),
+	( "ltu",	MO_U_Lt ),
+
+	( "flt",	MO_S_Lt ),
+	( "fle",	MO_S_Le ),
+	( "feq",	MO_Eq ),
+	( "fne",	MO_Ne ),
+	( "fgt",	MO_S_Gt ),
+	( "fge",	MO_S_Ge ),
+	( "fneg",	MO_S_Neg ),
+
+	( "and",	MO_And ),
+	( "or",		MO_Or ),
+	( "xor",	MO_Xor ),
+	( "com",	MO_Not ),
+	( "shl",	MO_Shl ),
+	( "shrl",	MO_U_Shr ),
+	( "shra",	MO_S_Shr ),
+
+	( "lobits8",  flip MO_U_Conv I8  ),
+	( "lobits16", flip MO_U_Conv I16 ),
+	( "lobits32", flip MO_U_Conv I32 ),
+	( "lobits64", flip MO_U_Conv I64 ),
+	( "sx16",     flip MO_S_Conv I16 ),
+	( "sx32",     flip MO_S_Conv I32 ),
+	( "sx64",     flip MO_S_Conv I64 ),
+	( "zx16",     flip MO_U_Conv I16 ),
+	( "zx32",     flip MO_U_Conv I32 ),
+	( "zx64",     flip MO_U_Conv I64 ),
+	( "f2f32",    flip MO_S_Conv F32 ),  -- TODO; rounding mode
+	( "f2f64",    flip MO_S_Conv F64 ),  -- TODO; rounding mode
+	( "f2i8",     flip MO_S_Conv I8 ),
+	( "f2i16",    flip MO_S_Conv I8 ),
+	( "f2i32",    flip MO_S_Conv I8 ),
+	( "f2i64",    flip MO_S_Conv I8 ),
+	( "i2f32",    flip MO_S_Conv F32 ),
+	( "i2f64",    flip MO_S_Conv F64 )
+	]
+
+parseHint :: String -> P MachHint
+parseHint "ptr"    = return PtrHint
+parseHint "signed" = return SignedHint
+parseHint "float"  = return FloatHint
+parseHint str      = fail ("unrecognised hint: " ++ str)
+
+-- labels are always pointers, so we might as well infer the hint
+inferHint :: CmmExpr -> MachHint
+inferHint (CmmLit (CmmLabel _)) = PtrHint
+inferHint (CmmReg (CmmGlobal g)) | isPtrGlobalReg g = PtrHint
+inferHint _ = NoHint
+
+isPtrGlobalReg Sp		= True
+isPtrGlobalReg SpLim		= True
+isPtrGlobalReg Hp		= True
+isPtrGlobalReg HpLim		= True
+isPtrGlobalReg CurrentTSO	= True
+isPtrGlobalReg CurrentNursery	= True
+isPtrGlobalReg _		= False
+
+happyError :: P a
+happyError = srcParseFail
+
+-- -----------------------------------------------------------------------------
+-- Statement-level macros
+
+stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
+stmtMacro fun args_code = do
+  case lookupUFM stmtMacros fun of
+    Nothing -> fail ("unknown macro: " ++ unpackFS fun)
+    Just fcode -> return $ do
+	args <- sequence args_code
+	code (fcode args)
+
+stmtMacros :: UniqFM ([CmmExpr] -> Code)
+stmtMacros = listToUFM [
+  ( FSLIT("CCS_ALLOC"),		   \[words,ccs]  -> profAlloc words ccs ),
+  ( FSLIT("CLOSE_NURSERY"),	   \[]  -> emitCloseNursery ),
+  ( FSLIT("ENTER_CCS_PAP_CL"),     \[e] -> enterCostCentrePAP e ),
+  ( FSLIT("ENTER_CCS_THUNK"),      \[e] -> enterCostCentreThunk e ),
+  ( FSLIT("HP_CHK_GEN"),           \[words,liveness,reentry] -> 
+                                      hpChkGen words liveness reentry ),
+  ( FSLIT("HP_CHK_NP_ASSIGN_SP0"), \[e,f] -> hpChkNodePointsAssignSp0 e f ),
+  ( FSLIT("LOAD_THREAD_STATE"),    \[] -> emitLoadThreadState ),
+  ( FSLIT("LDV_ENTER"),            \[e] -> ldvEnter e ),
+  ( FSLIT("LDV_RECORD_CREATE"),    \[e] -> ldvRecordCreate e ),
+  ( FSLIT("OPEN_NURSERY"),	   \[]  -> emitOpenNursery ),
+  ( FSLIT("PUSH_UPD_FRAME"),	   \[sp,e] -> emitPushUpdateFrame sp e ),
+  ( FSLIT("SAVE_THREAD_STATE"),    \[] -> emitSaveThreadState ),
+  ( FSLIT("SET_HDR"),		   \[ptr,info,ccs] -> 
+					emitSetDynHdr ptr info ccs ),
+  ( FSLIT("STK_CHK_GEN"),          \[words,liveness,reentry] -> 
+                                      stkChkGen words liveness reentry ),
+  ( FSLIT("STK_CHK_NP"),	   \[e] -> stkChkNodePoints e ),
+  ( FSLIT("TICK_ALLOC_PRIM"), 	   \[hdr,goods,slop] -> 
+					tickyAllocPrim hdr goods slop ),
+  ( FSLIT("TICK_ALLOC_PAP"),       \[goods,slop] -> 
+					tickyAllocPAP goods slop ),
+  ( FSLIT("TICK_ALLOC_UP_THK"),    \[goods,slop] -> 
+					tickyAllocThunk goods slop ),
+  ( FSLIT("UPD_BH_UPDATABLE"),       \[] -> emitBlackHoleCode False ),
+  ( FSLIT("UPD_BH_SINGLE_ENTRY"),    \[] -> emitBlackHoleCode True ),
+
+  ( FSLIT("RET_P"),	\[a] ->       emitRetUT [(PtrArg,a)]),
+  ( FSLIT("RET_N"),	\[a] ->       emitRetUT [(NonPtrArg,a)]),
+  ( FSLIT("RET_PP"),	\[a,b] ->     emitRetUT [(PtrArg,a),(PtrArg,b)]),
+  ( FSLIT("RET_NN"),	\[a,b] ->     emitRetUT [(NonPtrArg,a),(NonPtrArg,b)]),
+  ( FSLIT("RET_NP"),	\[a,b] ->     emitRetUT [(NonPtrArg,a),(PtrArg,b)]),
+  ( FSLIT("RET_PPP"),	\[a,b,c] ->   emitRetUT [(PtrArg,a),(PtrArg,b),(PtrArg,c)]),
+  ( FSLIT("RET_NNP"),	\[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
+  ( FSLIT("RET_NNNP"),	\[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(PtrArg,d)]),
+  ( FSLIT("RET_NPNP"),	\[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(PtrArg,b),(NonPtrArg,c),(PtrArg,d)])
+
+ ]
+
+-- -----------------------------------------------------------------------------
+-- Our extended FCode monad.
+
+-- We add a mapping from names to CmmExpr, to support local variable names in
+-- the concrete C-- code.  The unique supply of the underlying FCode monad
+-- is used to grab a new unique for each local variable.
+
+-- In C--, a local variable can be declared anywhere within a proc,
+-- and it scopes from the beginning of the proc to the end.  Hence, we have
+-- to collect declarations as we parse the proc, and feed the environment
+-- back in circularly (to avoid a two-pass algorithm).
+
+type Decls = [(FastString,CmmExpr)]
+type Env   = UniqFM CmmExpr
+
+newtype ExtFCode a = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
+
+type ExtCode = ExtFCode ()
+
+returnExtFC a = EC $ \e s -> return (s, a)
+thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
+
+instance Monad ExtFCode where
+  (>>=) = thenExtFC
+  return = returnExtFC
+
+-- This function takes the variable decarations and imports and makes 
+-- an environment, which is looped back into the computation.  In this
+-- way, we can have embedded declarations that scope over the whole
+-- procedure, and imports that scope over the entire module.
+loopDecls :: ExtFCode a -> ExtFCode a
+loopDecls (EC fcode) = 
+   EC $ \e s -> fixC (\ ~(decls,a) -> fcode (addListToUFM e decls) [])
+
+getEnv :: ExtFCode Env
+getEnv = EC $ \e s -> return (s, e)
+
+addVarDecl :: FastString -> CmmExpr -> ExtCode
+addVarDecl var expr = EC $ \e s -> return ((var,expr):s, ())
+
+newLocal :: MachRep -> FastString -> ExtCode
+newLocal ty name  = do
+   u <- code newUnique
+   addVarDecl name (CmmReg (CmmLocal (LocalReg u ty)))
+
+-- Unknown names are treated as if they had been 'import'ed.
+-- This saves us a lot of bother in the RTS sources, at the expense of
+-- deferring some errors to link time.
+lookupName :: FastString -> ExtFCode CmmExpr
+lookupName name = do
+  env <- getEnv
+  return $ 
+     case lookupUFM env name of
+	Nothing -> CmmLit (CmmLabel (mkRtsCodeLabelFS name))
+	Just e  -> e
+
+-- Lifting FCode computations into the ExtFCode monad:
+code :: FCode a -> ExtFCode a
+code fc = EC $ \e s -> do r <- fc; return (s, r)
+
+code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c))
+	 -> ExtFCode b -> ExtFCode c
+code2 f (EC ec) = EC $ \e s -> do ((s',b),c) <- f (ec e s); return (s',c)
+
+nopEC = code nopC
+stmtEC stmt = code (stmtC stmt)
+stmtsEC stmts = code (stmtsC stmts)
+getCgStmtsEC = code2 getCgStmts'
+
+forkLabelledCodeEC ec = do
+  stmts <- getCgStmtsEC ec
+  code (forkCgStmts stmts)
+
+retInfo name size live_bits cl_type vector = do
+  let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
+      info_lbl = mkRtsRetInfoLabelFS name
+      (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT 
+				(fromIntegral cl_type) vector
+  return (info_lbl, info1, info2)
+
+stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
+  basicInfo name (packHalfWordsCLit ptrs nptrs) 
+	srt_bitmap cl_type desc_str ty_str
+
+basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
+  lit1 <- if opt_SccProfilingOn 
+		   then code $ mkStringCLit desc_str
+		   else return (mkIntCLit 0)
+  lit2 <- if opt_SccProfilingOn 
+		   then code $ mkStringCLit ty_str
+		   else return (mkIntCLit 0)
+  let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type) 
+			(fromIntegral srt_bitmap)
+			layout
+  return (mkRtsInfoLabelFS name, info1, [])
+
+funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
+  (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
+			 cl_type desc_str ty_str 
+  let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
+		-- we leave most of the fields zero here.  This is only used
+		-- to generate the BCO info table in the RTS at the moment.
+  return (label,info1,info2)
+ where
+   zero = mkIntCLit 0
+
+
+staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
+staticClosure cl_label info payload
+  = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits
+  where  lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] []
+
+foreignCall
+	:: String
+	-> [ExtFCode (CmmReg,MachHint)]
+	-> ExtFCode CmmExpr
+	-> [ExtFCode (CmmExpr,MachHint)]
+	-> Maybe [GlobalReg] -> P ExtCode
+foreignCall "C" results_code expr_code args_code vols
+  = return $ do
+	results <- sequence results_code
+	expr <- expr_code
+	args <- sequence args_code
+        code (emitForeignCall' PlayRisky results 
+                 (CmmForeignCall expr CCallConv) args vols)
+foreignCall conv _ _ _ _
+  = fail ("unknown calling convention: " ++ conv)
+
+doStore :: MachRep -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
+doStore rep addr_code val_code
+  = do addr <- addr_code
+       val <- val_code
+	-- if the specified store type does not match the type of the expr
+	-- on the rhs, then we insert a coercion that will cause the type
+	-- mismatch to be flagged by cmm-lint.  If we don't do this, then
+	-- the store will happen at the wrong type, and the error will not
+	-- be noticed.
+       let coerce_val 
+		| cmmExprRep val /= rep = CmmMachOp (MO_U_Conv rep rep) [val]
+		| otherwise             = val
+       stmtEC (CmmStore addr coerce_val)
+
+-- Return an unboxed tuple.
+emitRetUT :: [(CgRep,CmmExpr)] -> Code
+emitRetUT args = do
+  tickyUnboxedTupleReturn (length args)  -- TICK
+  (sp, stmts) <- pushUnboxedTuple 0 args
+  emitStmts stmts
+  when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
+  stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
+
+-- -----------------------------------------------------------------------------
+-- If-then-else and boolean expressions
+
+data BoolExpr
+  = BoolExpr `BoolAnd` BoolExpr
+  | BoolExpr `BoolOr`  BoolExpr
+  | BoolNot BoolExpr
+  | BoolTest CmmExpr
+
+-- ToDo: smart constructors which simplify the boolean expression.
+
+ifThenElse cond then_part else_part = do
+     then_id <- code newLabelC
+     join_id <- code newLabelC
+     c <- cond
+     emitCond c then_id
+     else_part
+     stmtEC (CmmBranch join_id)
+     code (labelC then_id)
+     then_part
+     -- fall through to join
+     code (labelC join_id)
+
+-- 'emitCond cond true_id'  emits code to test whether the cond is true,
+-- branching to true_id if so, and falling through otherwise.
+emitCond (BoolTest e) then_id = do
+  stmtEC (CmmCondBranch e then_id)
+emitCond (BoolNot (BoolTest (CmmMachOp op args))) then_id
+  | Just op' <- maybeInvertComparison op
+  = emitCond (BoolTest (CmmMachOp op' args)) then_id
+emitCond (BoolNot e) then_id = do
+  else_id <- code newLabelC
+  emitCond e else_id
+  stmtEC (CmmBranch then_id)
+  code (labelC else_id)
+emitCond (e1 `BoolOr` e2) then_id = do
+  emitCond e1 then_id
+  emitCond e2 then_id
+emitCond (e1 `BoolAnd` e2) then_id = do
+	-- we'd like to invert one of the conditionals here to avoid an
+	-- extra branch instruction, but we can't use maybeInvertComparison
+	-- here because we can't look too closely at the expression since
+	-- we're in a loop.
+  and_id <- code newLabelC
+  else_id <- code newLabelC
+  emitCond e1 and_id
+  stmtEC (CmmBranch else_id)
+  code (labelC and_id)
+  emitCond e2 then_id
+  code (labelC else_id)
+
+
+-- -----------------------------------------------------------------------------
+-- Table jumps
+
+-- We use a simplified form of C-- switch statements for now.  A
+-- switch statement always compiles to a table jump.  Each arm can
+-- specify a list of values (not ranges), and there can be a single
+-- default branch.  The range of the table is given either by the
+-- optional range on the switch (eg. switch [0..7] {...}), or by
+-- the minimum/maximum values from the branches.
+
+doSwitch :: Maybe (Int,Int) -> ExtFCode CmmExpr -> [([Int],ExtCode)]
+         -> Maybe ExtCode -> ExtCode
+doSwitch mb_range scrut arms deflt
+   = do 
+	-- Compile code for the default branch
+	dflt_entry <- 
+		case deflt of
+		  Nothing -> return Nothing
+		  Just e  -> do b <- forkLabelledCodeEC e; return (Just b)
+
+	-- Compile each case branch
+	table_entries <- mapM emitArm arms
+
+	-- Construct the table
+	let
+	    all_entries = concat table_entries
+	    ixs = map fst all_entries
+	    (min,max) 
+		| Just (l,u) <- mb_range = (l,u)
+		| otherwise              = (minimum ixs, maximum ixs)
+
+	    entries = elems (accumArray (\_ a -> Just a) dflt_entry (min,max)
+				all_entries)
+	expr <- scrut
+	-- ToDo: check for out of range and jump to default if necessary
+        stmtEC (CmmSwitch expr entries)
+   where
+	emitArm :: ([Int],ExtCode) -> ExtFCode [(Int,BlockId)]
+	emitArm (ints,code) = do
+	   blockid <- forkLabelledCodeEC code
+	   return [ (i,blockid) | i <- ints ]
+
+
+-- -----------------------------------------------------------------------------
+-- Putting it all together
+
+-- The initial environment: we define some constants that the compiler
+-- knows about here.
+initEnv :: Env
+initEnv = listToUFM [
+  ( FSLIT("SIZEOF_StgHeader"), 
+	CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) ),
+  ( FSLIT("SIZEOF_StgInfoTable"),
+        CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) )
+  ]
+
+parseCmmFile :: DynFlags -> HomeModules -> FilePath -> IO (Maybe Cmm)
+parseCmmFile dflags hmods filename = do
+  showPass dflags "ParseCmm"
+  buf <- hGetStringBuffer filename
+  let
+	init_loc = mkSrcLoc (mkFastString filename) 1 0
+	init_state = (mkPState buf init_loc dflags) { lex_state = [0] }
+		-- reset the lex_state: the Lexer monad leaves some stuff
+		-- in there we don't want.
+  case unP cmmParse init_state of
+    PFailed span err -> do printError span err; return Nothing
+    POk _ code -> do
+	cmm <- initC dflags hmods no_module (getCmm (unEC code initEnv [] >> return ()))
+	dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
+	return (Just cmm)
+  where
+	no_module = panic "parseCmmFile: no module"
+}
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
new file mode 100644
index 0000000000..a04935b279
--- /dev/null
+++ b/compiler/cmm/CmmUtils.hs
@@ -0,0 +1,177 @@
+-----------------------------------------------------------------------------
+--
+-- Cmm utilities.
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+module CmmUtils( 
+	CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList,
+	isNopStmt,
+
+	isTrivialCmmExpr, hasNoGlobalRegs,
+
+	cmmRegOff, cmmLabelOff, cmmOffset, cmmOffsetLit, cmmIndex,
+	cmmOffsetExpr, cmmIndexExpr, cmmLoadIndex,
+
+ 	mkIntCLit, zeroCLit,
+
+	mkLblExpr,
+  ) where
+
+#include "HsVersions.h"
+
+import CLabel		( CLabel )
+import Cmm
+import MachOp
+import OrdList
+import Outputable
+
+---------------------------------------------------
+--
+--	CmmStmts
+--
+---------------------------------------------------
+
+type CmmStmts = OrdList CmmStmt
+
+noStmts :: CmmStmts
+noStmts = nilOL
+
+oneStmt :: CmmStmt -> CmmStmts
+oneStmt = unitOL
+
+mkStmts :: [CmmStmt] -> CmmStmts
+mkStmts = toOL
+
+plusStmts :: CmmStmts -> CmmStmts -> CmmStmts
+plusStmts = appOL
+
+stmtList :: CmmStmts -> [CmmStmt]
+stmtList = fromOL
+
+
+---------------------------------------------------
+--
+--	CmmStmt
+--
+---------------------------------------------------
+
+isNopStmt :: CmmStmt -> Bool
+-- If isNopStmt returns True, the stmt is definitely a no-op;
+-- but it might be a no-op even if isNopStmt returns False
+isNopStmt CmmNop 		       = True
+isNopStmt (CmmAssign r e) 	       = cheapEqReg r e
+isNopStmt (CmmStore e1 (CmmLoad e2 _)) = cheapEqExpr e1 e2
+isNopStmt s 			       = False
+
+cheapEqExpr :: CmmExpr -> CmmExpr -> Bool
+cheapEqExpr (CmmReg r)      e 		      = cheapEqReg r e
+cheapEqExpr (CmmRegOff r 0) e 		      = cheapEqReg r e
+cheapEqExpr (CmmRegOff r n) (CmmRegOff r' n') = r==r' && n==n'
+cheapEqExpr e1 		    e2		      = False
+
+cheapEqReg :: CmmReg -> CmmExpr -> Bool
+cheapEqReg r (CmmReg r')      = r==r'
+cheapEqReg r (CmmRegOff r' 0) = r==r'
+cheapEqReg r e		      = False
+
+---------------------------------------------------
+--
+--	CmmExpr
+--
+---------------------------------------------------
+
+isTrivialCmmExpr :: CmmExpr -> Bool
+isTrivialCmmExpr (CmmLoad _ _)   = False
+isTrivialCmmExpr (CmmMachOp _ _) = False
+isTrivialCmmExpr (CmmLit _)      = True
+isTrivialCmmExpr (CmmReg _)      = True
+isTrivialCmmExpr (CmmRegOff _ _) = True
+
+hasNoGlobalRegs :: CmmExpr -> Bool
+hasNoGlobalRegs (CmmLoad e _)   	   = hasNoGlobalRegs e
+hasNoGlobalRegs (CmmMachOp _ es) 	   = all hasNoGlobalRegs es
+hasNoGlobalRegs (CmmLit _)      	   = True
+hasNoGlobalRegs (CmmReg (CmmLocal _))      = True
+hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
+hasNoGlobalRegs _ = False
+
+---------------------------------------------------
+--
+--	Expr Construction helpers
+--
+---------------------------------------------------
+
+cmmOffsetExpr :: CmmExpr -> CmmExpr -> CmmExpr
+-- assumes base and offset have the same MachRep
+cmmOffsetExpr e (CmmLit (CmmInt n _)) = cmmOffset e (fromInteger n)
+cmmOffsetExpr e byte_off = CmmMachOp (MO_Add (cmmExprRep e)) [e, byte_off]
+
+-- NB. Do *not* inspect the value of the offset in these smart constructors!!!
+--
+-- because the offset is sometimes involved in a loop in the code generator
+-- (we don't know the real Hp offset until we've generated code for the entire
+-- basic block, for example).  So we cannot eliminate zero offsets at this
+-- stage; they're eliminated later instead (either during printing or
+-- a later optimisation step on Cmm).
+--
+cmmOffset :: CmmExpr -> Int -> CmmExpr
+cmmOffset (CmmReg reg)      byte_off = cmmRegOff reg byte_off
+cmmOffset (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
+cmmOffset (CmmLit lit)      byte_off = CmmLit (cmmOffsetLit lit byte_off)
+cmmOffset (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
+  = CmmMachOp (MO_Add rep) 
+	      [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
+cmmOffset expr byte_off
+  = CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt (toInteger byte_off) rep)]
+  where
+    rep = cmmExprRep expr
+
+-- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.
+cmmRegOff :: CmmReg -> Int -> CmmExpr
+cmmRegOff reg byte_off = CmmRegOff reg byte_off
+
+cmmOffsetLit :: CmmLit -> Int -> CmmLit
+cmmOffsetLit (CmmLabel l)      byte_off = cmmLabelOff	l byte_off
+cmmOffsetLit (CmmLabelOff l m) byte_off = cmmLabelOff	l (m+byte_off)
+cmmOffsetLit (CmmInt m rep)    byte_off = CmmInt (m + fromIntegral byte_off) rep
+cmmOffsetLit other	       byte_off = pprPanic "cmmOffsetLit" (ppr byte_off)
+
+cmmLabelOff :: CLabel -> Int -> CmmLit
+-- Smart constructor for CmmLabelOff
+cmmLabelOff lbl 0        = CmmLabel lbl
+cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off
+
+-- | Useful for creating an index into an array, with a staticaly known offset.
+cmmIndex :: MachRep -> CmmExpr -> Int -> CmmExpr
+cmmIndex rep base idx = cmmOffset base (idx * machRepByteWidth rep)
+
+-- | Useful for creating an index into an array, with an unknown offset.
+cmmIndexExpr :: MachRep -> CmmExpr -> CmmExpr -> CmmExpr
+cmmIndexExpr rep base (CmmLit (CmmInt n _)) = cmmIndex rep base (fromInteger n)
+cmmIndexExpr rep base idx =
+  cmmOffsetExpr base byte_off
+  where
+    idx_rep = cmmExprRep idx
+    byte_off = CmmMachOp (MO_Shl idx_rep) [
+		  idx, CmmLit (mkIntCLit (machRepLogWidth rep))]
+
+cmmLoadIndex :: MachRep -> CmmExpr -> Int -> CmmExpr
+cmmLoadIndex rep expr ix = CmmLoad (cmmIndex rep expr ix) rep
+
+---------------------------------------------------
+--
+--	Literal construction functions
+--
+---------------------------------------------------
+
+mkIntCLit :: Int -> CmmLit
+mkIntCLit i = CmmInt (toInteger i) wordRep
+
+zeroCLit :: CmmLit
+zeroCLit = CmmInt 0 wordRep
+
+mkLblExpr :: CLabel -> CmmExpr
+mkLblExpr lbl = CmmLit (CmmLabel lbl)
diff --git a/compiler/cmm/MachOp.hs b/compiler/cmm/MachOp.hs
new file mode 100644
index 0000000000..5bbff6de78
--- /dev/null
+++ b/compiler/cmm/MachOp.hs
@@ -0,0 +1,652 @@
+-----------------------------------------------------------------------------
+--
+-- (c) The University of Glasgow 2002-2004
+--
+-- Low-level machine operations, used in the Cmm datatype.
+--
+-----------------------------------------------------------------------------
+
+module MachOp 	( 
+	MachRep(..), 
+	machRepBitWidth,
+	machRepByteWidth,
+	machRepLogWidth,
+	isFloatingRep,
+
+	MachHint(..),
+
+	MachOp(..), 
+	pprMachOp,
+	isCommutableMachOp,
+	isAssociativeMachOp,
+	isComparisonMachOp,
+	resultRepOfMachOp,
+	machOpArgReps,
+	maybeInvertComparison,
+
+	CallishMachOp(..),
+	pprCallishMachOp,
+
+	wordRep,
+	halfWordRep,
+	cIntRep, cLongRep,
+
+	mo_wordAdd,
+	mo_wordSub,
+	mo_wordEq,
+	mo_wordNe,
+	mo_wordMul,
+	mo_wordSQuot,
+	mo_wordSRem,
+	mo_wordSNeg,
+	mo_wordUQuot,
+	mo_wordURem,
+
+	mo_wordSGe,
+	mo_wordSLe,
+	mo_wordSGt,
+	mo_wordSLt,
+
+	mo_wordUGe,
+	mo_wordULe,
+	mo_wordUGt,
+	mo_wordULt,
+
+	mo_wordAnd,
+	mo_wordOr,
+	mo_wordXor,
+	mo_wordNot,
+	mo_wordShl,
+	mo_wordSShr,
+	mo_wordUShr,
+
+	mo_u_8To32,
+	mo_s_8To32,
+	mo_u_16To32,
+	mo_s_16To32,
+
+	mo_u_8ToWord,
+	mo_s_8ToWord,
+	mo_u_16ToWord,
+	mo_s_16ToWord,
+	mo_u_32ToWord,
+	mo_s_32ToWord,
+
+	mo_32To8,
+	mo_32To16,
+	mo_WordTo8,
+	mo_WordTo16,
+	mo_WordTo32,
+  ) where
+
+#include "HsVersions.h"
+
+import Constants
+import Outputable
+
+-- -----------------------------------------------------------------------------
+-- MachRep
+
+{- |
+A MachRep is the "representation" of a value in Cmm.  It is used for
+resource allocation: eg. which kind of register a value should be
+stored in.  
+
+The primary requirement is that there exists a function
+
+  cmmExprRep :: CmmExpr -> MachRep
+
+This means that:
+
+  - a register has an implicit MachRep
+  - a literal has an implicit MachRep
+  - an operation (MachOp) has an implicit result MachRep
+
+It also means that we can check that the arguments to a MachOp have
+the correct MachRep, i.e. we can do a kind of lint-style type checking
+on Cmm.
+-}
+
+data MachRep
+  = I8
+  | I16
+  | I32
+  | I64
+  | I128
+  | F32
+  | F64
+  | F80		-- extended double-precision, used in x86 native codegen only.
+  deriving (Eq, Ord, Show)
+
+mrStr I8   = SLIT("I8")
+mrStr I16  = SLIT("I16")
+mrStr I32  = SLIT("I32")
+mrStr I64  = SLIT("I64")
+mrStr I128 = SLIT("I128")
+mrStr F32  = SLIT("F32")
+mrStr F64  = SLIT("F64")
+mrStr F80  = SLIT("F80")
+
+instance Outputable MachRep where
+   ppr rep = ptext (mrStr rep)
+
+{- 
+Implementation notes:
+
+It might suffice to keep just a width, without distinguishing between
+floating and integer types.  However, keeping the distinction will
+help the native code generator to assign registers more easily.
+-}
+
+{-
+Should a MachRep include a signed vs. unsigned distinction?
+
+This is very much like a "hint" in C-- terminology: it isn't necessary
+in order to generate correct code, but it might be useful in that the
+compiler can generate better code if it has access to higher-level
+hints about data.  This is important at call boundaries, because the
+definition of a function is not visible at all of its call sites, so
+the compiler cannot infer the hints.
+
+Here in Cmm, we're taking a slightly different approach.  We include
+the int vs. float hint in the MachRep, because (a) the majority of
+platforms have a strong distinction between float and int registers,
+and (b) we don't want to do any heavyweight hint-inference in the
+native code backend in order to get good code.  We're treating the
+hint more like a type: our Cmm is always completely consistent with
+respect to hints.  All coercions between float and int are explicit.
+
+What about the signed vs. unsigned hint?  This information might be
+useful if we want to keep sub-word-sized values in word-size
+registers, which we must do if we only have word-sized registers.
+
+On such a system, there are two straightforward conventions for
+representing sub-word-sized values:
+
+(a) Leave the upper bits undefined.  Comparison operations must
+    sign- or zero-extend both operands before comparing them,
+    depending on whether the comparison is signed or unsigned.
+
+(b) Always keep the values sign- or zero-extended as appropriate.
+    Arithmetic operations must narrow the result to the appropriate
+    size.
+
+A clever compiler might not use either (a) or (b) exclusively, instead
+it would attempt to minimize the coercions by analysis: the same kind
+of analysis that propagates hints around.  In Cmm we don't want to
+have to do this, so we plump for having richer types and keeping the
+type information consistent.
+
+If signed/unsigned hints are missing from MachRep, then the only
+choice we have is (a), because we don't know whether the result of an
+operation should be sign- or zero-extended.
+
+Many architectures have extending load operations, which work well
+with (b).  To make use of them with (a), you need to know whether the
+value is going to be sign- or zero-extended by an enclosing comparison
+(for example), which involves knowing above the context.  This is
+doable but more complex.
+
+Further complicating the issue is foreign calls: a foreign calling
+convention can specify that signed 8-bit quantities are passed as
+sign-extended 32 bit quantities, for example (this is the case on the
+PowerPC).  So we *do* need sign information on foreign call arguments.
+
+Pros for adding signed vs. unsigned to MachRep:
+
+  - It would let us use convention (b) above, and get easier
+    code generation for extending loads.
+
+  - Less information required on foreign calls.
+  
+  - MachOp type would be simpler
+
+Cons:
+
+  - More complexity
+
+  - What is the MachRep for a VanillaReg?  Currently it is
+    always wordRep, but now we have to decide whether it is
+    signed or unsigned.  The same VanillaReg can thus have
+    different MachReps in different parts of the program.
+
+  - Extra coercions cluttering up expressions.
+
+Currently for GHC, the foreign call point is moot, because we do our
+own promotion of sub-word-sized values to word-sized values.  The Int8
+type is represnted by an Int# which is kept sign-extended at all times
+(this is slightly naughty, because we're making assumptions about the
+C calling convention rather early on in the compiler).  However, given
+this, the cons outweigh the pros.
+
+-}
+
+
+machRepBitWidth :: MachRep -> Int
+machRepBitWidth I8   = 8
+machRepBitWidth I16  = 16
+machRepBitWidth I32  = 32
+machRepBitWidth I64  = 64
+machRepBitWidth I128 = 128
+machRepBitWidth F32  = 32
+machRepBitWidth F64  = 64
+machRepBitWidth F80  = 80
+
+machRepByteWidth :: MachRep -> Int
+machRepByteWidth I8   = 1
+machRepByteWidth I16  = 2
+machRepByteWidth I32  = 4
+machRepByteWidth I64  = 8
+machRepByteWidth I128 = 16
+machRepByteWidth F32  = 4
+machRepByteWidth F64  = 8
+machRepByteWidth F80  = 10
+
+-- log_2 of the width in bytes, useful for generating shifts.
+machRepLogWidth :: MachRep -> Int
+machRepLogWidth I8   = 0
+machRepLogWidth I16  = 1
+machRepLogWidth I32  = 2
+machRepLogWidth I64  = 3
+machRepLogWidth I128 = 4
+machRepLogWidth F32  = 2
+machRepLogWidth F64  = 3
+machRepLogWidth F80  = panic "machRepLogWidth: F80"
+
+isFloatingRep :: MachRep -> Bool
+isFloatingRep F32 = True
+isFloatingRep F64 = True
+isFloatingRep F80 = True
+isFloatingRep _   = False
+
+-- -----------------------------------------------------------------------------
+-- Hints
+
+{-
+A hint gives a little more information about a data value.  Hints are
+used on the arguments to a foreign call, where the code generator needs
+to know some extra information on top of the MachRep of each argument in
+order to generate a correct call.
+-}
+
+data MachHint
+  = NoHint
+  | PtrHint
+  | SignedHint
+  | FloatHint
+  deriving Eq
+
+mhStr NoHint     = SLIT("NoHint")
+mhStr PtrHint    = SLIT("PtrHint")
+mhStr SignedHint = SLIT("SignedHint")
+mhStr FloatHint  = SLIT("FloatHint")
+
+instance Outputable MachHint where
+   ppr hint = ptext (mhStr hint)
+
+-- -----------------------------------------------------------------------------
+-- MachOp
+
+{- |
+Machine-level primops; ones which we can reasonably delegate to the
+native code generators to handle.  Basically contains C's primops
+and no others.
+
+Nomenclature: all ops indicate width and signedness, where
+appropriate.  Widths: 8\/16\/32\/64 means the given size, obviously.
+Nat means the operation works on STG word sized objects.
+Signedness: S means signed, U means unsigned.  For operations where
+signedness is irrelevant or makes no difference (for example
+integer add), the signedness component is omitted.
+
+An exception: NatP is a ptr-typed native word.  From the point of
+view of the native code generators this distinction is irrelevant,
+but the C code generator sometimes needs this info to emit the
+right casts.  
+-}
+
+data MachOp
+
+  -- Integer operations
+  = MO_Add    MachRep
+  | MO_Sub    MachRep
+  | MO_Eq     MachRep
+  | MO_Ne     MachRep
+  | MO_Mul    MachRep		-- low word of multiply
+  | MO_S_MulMayOflo MachRep 	-- nonzero if signed multiply overflows
+  | MO_S_Quot MachRep		-- signed / (same semantics as IntQuotOp)
+  | MO_S_Rem  MachRep		-- signed % (same semantics as IntRemOp)
+  | MO_S_Neg  MachRep		-- unary -
+  | MO_U_MulMayOflo MachRep	-- nonzero if unsigned multiply overflows
+  | MO_U_Quot MachRep		-- unsigned / (same semantics as WordQuotOp)
+  | MO_U_Rem  MachRep		-- unsigned % (same semantics as WordRemOp)
+
+  -- Signed comparisons (floating-point comparisons also use these)
+  | MO_S_Ge MachRep
+  | MO_S_Le MachRep
+  | MO_S_Gt MachRep
+  | MO_S_Lt MachRep
+
+  -- Unsigned comparisons
+  | MO_U_Ge MachRep
+  | MO_U_Le MachRep
+  | MO_U_Gt MachRep
+  | MO_U_Lt MachRep
+
+  -- Bitwise operations.  Not all of these may be supported at all sizes,
+  -- and only integral MachReps are valid.
+  | MO_And   MachRep
+  | MO_Or    MachRep
+  | MO_Xor   MachRep
+  | MO_Not   MachRep
+  | MO_Shl   MachRep
+  | MO_U_Shr MachRep	-- unsigned shift right
+  | MO_S_Shr MachRep	-- signed shift right
+
+  -- Conversions.  Some of these will be NOPs.
+  -- Floating-point conversions use the signed variant.
+  | MO_S_Conv MachRep{-from-} MachRep{-to-}	-- signed conversion
+  | MO_U_Conv MachRep{-from-} MachRep{-to-}	-- unsigned conversion
+
+  deriving (Eq, Show)
+
+pprMachOp :: MachOp -> SDoc
+pprMachOp mo = text (show mo)
+
+
+-- These MachOps tend to be implemented by foreign calls in some backends,
+-- so we separate them out.  In Cmm, these can only occur in a
+-- statement position, in contrast to an ordinary MachOp which can occur
+-- anywhere in an expression.
+data CallishMachOp
+  = MO_F64_Pwr
+  | MO_F64_Sin
+  | MO_F64_Cos
+  | MO_F64_Tan
+  | MO_F64_Sinh
+  | MO_F64_Cosh
+  | MO_F64_Tanh
+  | MO_F64_Asin
+  | MO_F64_Acos
+  | MO_F64_Atan
+  | MO_F64_Log
+  | MO_F64_Exp
+  | MO_F64_Sqrt
+  | MO_F32_Pwr
+  | MO_F32_Sin
+  | MO_F32_Cos
+  | MO_F32_Tan
+  | MO_F32_Sinh
+  | MO_F32_Cosh
+  | MO_F32_Tanh
+  | MO_F32_Asin
+  | MO_F32_Acos
+  | MO_F32_Atan
+  | MO_F32_Log
+  | MO_F32_Exp
+  | MO_F32_Sqrt
+  deriving (Eq, Show)
+
+pprCallishMachOp :: CallishMachOp -> SDoc
+pprCallishMachOp mo = text (show mo)
+
+-- -----------------------------------------------------------------------------
+-- Some common MachReps
+
+-- A 'wordRep' is a machine word on the target architecture
+-- Specifically, it is the size of an Int#, Word#, Addr# 
+-- and the unit of allocation on the stack and the heap
+-- Any pointer is also guaranteed to be a wordRep.
+
+wordRep | wORD_SIZE == 4 = I32
+	| wORD_SIZE == 8 = I64
+	| otherwise      = panic "MachOp.wordRep: Unknown word size"
+
+halfWordRep | wORD_SIZE == 4 = I16
+	    | wORD_SIZE == 8 = I32
+	    | otherwise      = panic "MachOp.halfWordRep: Unknown word size"
+
+mo_wordAdd	= MO_Add wordRep
+mo_wordSub	= MO_Sub wordRep
+mo_wordEq 	= MO_Eq  wordRep
+mo_wordNe 	= MO_Ne  wordRep
+mo_wordMul	= MO_Mul wordRep
+mo_wordSQuot	= MO_S_Quot wordRep
+mo_wordSRem	= MO_S_Rem wordRep
+mo_wordSNeg	= MO_S_Neg wordRep
+mo_wordUQuot	= MO_U_Quot wordRep
+mo_wordURem	= MO_U_Rem wordRep
+
+mo_wordSGe	= MO_S_Ge  wordRep
+mo_wordSLe	= MO_S_Le  wordRep
+mo_wordSGt	= MO_S_Gt  wordRep
+mo_wordSLt	= MO_S_Lt  wordRep
+
+mo_wordUGe	= MO_U_Ge  wordRep
+mo_wordULe	= MO_U_Le  wordRep
+mo_wordUGt	= MO_U_Gt  wordRep
+mo_wordULt	= MO_U_Lt  wordRep
+
+mo_wordAnd	= MO_And wordRep
+mo_wordOr 	= MO_Or	 wordRep
+mo_wordXor	= MO_Xor wordRep
+mo_wordNot	= MO_Not wordRep
+mo_wordShl	= MO_Shl wordRep
+mo_wordSShr	= MO_S_Shr wordRep 
+mo_wordUShr	= MO_U_Shr wordRep 
+
+mo_u_8To32	= MO_U_Conv I8 I32
+mo_s_8To32	= MO_S_Conv I8 I32
+mo_u_16To32	= MO_U_Conv I16 I32
+mo_s_16To32	= MO_S_Conv I16 I32
+
+mo_u_8ToWord	= MO_U_Conv I8  wordRep
+mo_s_8ToWord	= MO_S_Conv I8  wordRep
+mo_u_16ToWord	= MO_U_Conv I16 wordRep
+mo_s_16ToWord	= MO_S_Conv I16 wordRep
+mo_s_32ToWord	= MO_S_Conv I32 wordRep
+mo_u_32ToWord	= MO_U_Conv I32 wordRep
+
+mo_WordTo8	= MO_U_Conv wordRep I8
+mo_WordTo16	= MO_U_Conv wordRep I16
+mo_WordTo32	= MO_U_Conv wordRep I32
+
+mo_32To8	= MO_U_Conv I32 I8
+mo_32To16	= MO_U_Conv I32 I16
+
+-- cIntRep is the MachRep for a C-language 'int'
+#if SIZEOF_INT == 4
+cIntRep = I32
+#elif  SIZEOF_INT == 8
+cIntRep = I64
+#endif
+
+#if SIZEOF_LONG == 4
+cLongRep = I32
+#elif  SIZEOF_LONG == 8
+cLongRep = I64
+#endif
+
+-- ----------------------------------------------------------------------------
+-- isCommutableMachOp
+
+{- |
+Returns 'True' if the MachOp has commutable arguments.  This is used
+in the platform-independent Cmm optimisations.
+
+If in doubt, return 'False'.  This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isCommutableMachOp :: MachOp -> Bool
+isCommutableMachOp mop = 
+  case mop of
+	MO_Add _ 		-> True
+	MO_Eq _			-> True
+	MO_Ne _			-> True
+	MO_Mul _		-> True
+	MO_S_MulMayOflo _	-> True
+	MO_U_MulMayOflo _	-> True
+	MO_And _		-> True
+	MO_Or _			-> True
+	MO_Xor _		-> True
+	_other			-> False
+
+-- ----------------------------------------------------------------------------
+-- isAssociativeMachOp
+
+{- |
+Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@)
+This is used in the platform-independent Cmm optimisations.
+
+If in doubt, return 'False'.  This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isAssociativeMachOp :: MachOp -> Bool
+isAssociativeMachOp mop = 
+  case mop of
+	MO_Add r 	-> not (isFloatingRep r)
+	MO_Mul r	-> not (isFloatingRep r)
+	MO_And _	-> True
+	MO_Or _		-> True
+	MO_Xor _	-> True
+	_other		-> False
+
+-- ----------------------------------------------------------------------------
+-- isComparisonMachOp
+
+{- | 
+Returns 'True' if the MachOp is a comparison.
+
+If in doubt, return False.  This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isComparisonMachOp :: MachOp -> Bool
+isComparisonMachOp mop = 
+  case mop of
+    MO_Eq   _  -> True
+    MO_Ne   _  -> True
+    MO_S_Ge _  -> True
+    MO_S_Le _  -> True
+    MO_S_Gt _  -> True
+    MO_S_Lt _  -> True
+    MO_U_Ge _  -> True
+    MO_U_Le _  -> True
+    MO_U_Gt _  -> True
+    MO_U_Lt _  -> True
+    _other     -> False
+
+-- -----------------------------------------------------------------------------
+-- Inverting conditions
+
+-- Sometimes it's useful to be able to invert the sense of a
+-- condition.  Not all conditional tests are invertible: in
+-- particular, floating point conditionals cannot be inverted, because
+-- there exist floating-point values which return False for both senses
+-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)).
+
+maybeInvertComparison :: MachOp -> Maybe MachOp
+maybeInvertComparison op
+  = case op of
+	MO_Eq r    | not (isFloatingRep r) -> Just (MO_Ne r)
+	MO_Ne r	   | not (isFloatingRep r) -> Just (MO_Eq r)
+	MO_U_Lt r  | not (isFloatingRep r) -> Just (MO_U_Ge r)
+	MO_U_Gt r  | not (isFloatingRep r) -> Just (MO_U_Le r)
+	MO_U_Le r  | not (isFloatingRep r) -> Just (MO_U_Gt r)
+	MO_U_Ge r  | not (isFloatingRep r) -> Just (MO_U_Lt r)
+	MO_S_Lt r  | not (isFloatingRep r) -> Just (MO_S_Ge r)
+	MO_S_Gt r  | not (isFloatingRep r) -> Just (MO_S_Le r)
+	MO_S_Le r  | not (isFloatingRep r) -> Just (MO_S_Gt r)
+	MO_S_Ge r  | not (isFloatingRep r) -> Just (MO_S_Lt r)
+	_other  -> Nothing
+
+-- ----------------------------------------------------------------------------
+-- resultRepOfMachOp
+
+{- |
+Returns the MachRep of the result of a MachOp.
+-}
+resultRepOfMachOp :: MachOp -> MachRep
+resultRepOfMachOp mop =
+  case mop of
+    MO_Add    r		-> r
+    MO_Sub    r		-> r
+    MO_Eq     r		-> comparisonResultRep
+    MO_Ne     r		-> comparisonResultRep
+    MO_Mul    r		-> r
+    MO_S_MulMayOflo r	-> r
+    MO_S_Quot r		-> r
+    MO_S_Rem  r		-> r
+    MO_S_Neg  r		-> r
+    MO_U_MulMayOflo r	-> r
+    MO_U_Quot r		-> r
+    MO_U_Rem  r		-> r
+
+    MO_S_Ge r		-> comparisonResultRep
+    MO_S_Le r		-> comparisonResultRep
+    MO_S_Gt r		-> comparisonResultRep
+    MO_S_Lt r		-> comparisonResultRep
+
+    MO_U_Ge r		-> comparisonResultRep
+    MO_U_Le r		-> comparisonResultRep
+    MO_U_Gt r		-> comparisonResultRep
+    MO_U_Lt r		-> comparisonResultRep
+
+    MO_And   r		-> r
+    MO_Or    r		-> r
+    MO_Xor   r		-> r
+    MO_Not   r		-> r
+    MO_Shl   r		-> r
+    MO_U_Shr r		-> r
+    MO_S_Shr r		-> r
+
+    MO_S_Conv from to	-> to
+    MO_U_Conv from to	-> to
+
+
+comparisonResultRep = wordRep  -- is it?
+
+
+-- -----------------------------------------------------------------------------
+-- machOpArgReps
+
+-- | This function is used for debugging only: we can check whether an
+-- application of a MachOp is "type-correct" by checking that the MachReps of
+-- its arguments are the same as the MachOp expects.  This is used when 
+-- linting a CmmExpr.
+
+machOpArgReps :: MachOp -> [MachRep]
+machOpArgReps op = 
+  case op of
+    MO_Add    r		-> [r,r]
+    MO_Sub    r		-> [r,r]
+    MO_Eq     r		-> [r,r]
+    MO_Ne     r		-> [r,r]
+    MO_Mul    r		-> [r,r]
+    MO_S_MulMayOflo r	-> [r,r]
+    MO_S_Quot r		-> [r,r]
+    MO_S_Rem  r		-> [r,r]
+    MO_S_Neg  r		-> [r]
+    MO_U_MulMayOflo r	-> [r,r]
+    MO_U_Quot r		-> [r,r]
+    MO_U_Rem  r		-> [r,r]
+
+    MO_S_Ge r		-> [r,r]
+    MO_S_Le r		-> [r,r]
+    MO_S_Gt r		-> [r,r]
+    MO_S_Lt r		-> [r,r]
+
+    MO_U_Ge r		-> [r,r]
+    MO_U_Le r		-> [r,r]
+    MO_U_Gt r		-> [r,r]
+    MO_U_Lt r		-> [r,r]
+
+    MO_And   r		-> [r,r]
+    MO_Or    r		-> [r,r]
+    MO_Xor   r		-> [r,r]
+    MO_Not   r		-> [r]
+    MO_Shl   r		-> [r,wordRep]
+    MO_U_Shr r		-> [r,wordRep]
+    MO_S_Shr r		-> [r,wordRep]
+
+    MO_S_Conv from to	-> [from]
+    MO_U_Conv from to	-> [from]
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
new file mode 100644
index 0000000000..a8d30668b7
--- /dev/null
+++ b/compiler/cmm/PprC.hs
@@ -0,0 +1,1028 @@
+-----------------------------------------------------------------------------
+--
+-- Pretty-printing of Cmm as C, suitable for feeding gcc
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+--
+-- Print Cmm as real C, for -fvia-C
+--
+-- This is simpler than the old PprAbsC, because Cmm is "macro-expanded"
+-- relative to the old AbstractC, and many oddities/decorations have
+-- disappeared from the data type.
+--
+
+-- ToDo: save/restore volatile registers around calls.
+
+module PprC (
+        writeCs,
+        pprStringInCStyle 
+  ) where
+
+#include "HsVersions.h"
+
+-- Cmm stuff
+import Cmm
+import CLabel
+import MachOp
+import ForeignCall
+
+-- Utils
+import DynFlags		( DynFlags, DynFlag(..), dopt )
+import Unique           ( getUnique )
+import UniqSet
+import FiniteMap
+import UniqFM		( eltsUFM )
+import FastString
+import Outputable
+import Constants
+import StaticFlags 	( opt_Unregisterised )
+
+-- The rest
+import Data.List        ( intersperse, groupBy )
+import Data.Bits        ( shiftR )
+import Char             ( ord, chr )
+import IO               ( Handle )
+import DATA_BITS
+import Data.Word	( Word8 )
+
+#ifdef DEBUG
+import PprCmm		() -- instances only
+-- import Debug.Trace
+#endif
+
+#if __GLASGOW_HASKELL__ >= 504
+import Data.Array.ST
+#endif
+import MONAD_ST
+
+-- --------------------------------------------------------------------------
+-- Top level
+
+pprCs :: DynFlags -> [Cmm] -> SDoc
+pprCs dflags cmms
+ = pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
+ where
+   split_marker
+     | dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER")
+     | otherwise     	         = empty
+
+writeCs :: DynFlags -> Handle -> [Cmm] -> IO ()
+writeCs dflags handle cmms 
+  = printForC handle (pprCs dflags cmms)
+
+-- --------------------------------------------------------------------------
+-- Now do some real work
+--
+-- for fun, we could call cmmToCmm over the tops...
+--
+
+pprC :: Cmm -> SDoc
+pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
+
+--
+-- top level procs
+-- 
+pprTop :: CmmTop -> SDoc
+pprTop (CmmProc info clbl _params blocks) =
+    (if not (null info)
+        then pprDataExterns info $$
+             pprWordArray (entryLblToInfoLbl clbl) info
+        else empty) $$
+    (case blocks of
+        [] -> empty
+         -- the first block doesn't get a label:
+        (BasicBlock _ stmts : rest) -> vcat [
+	   text "",
+	   extern_decls,
+           (if (externallyVisibleCLabel clbl)
+                    then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace,
+           nest 8 temp_decls,
+           nest 8 mkFB_,
+           nest 8 (vcat (map pprStmt stmts)) $$
+              vcat (map pprBBlock rest),
+           nest 8 mkFE_,
+           rbrace ]
+    )
+  where
+	(temp_decls, extern_decls) = pprTempAndExternDecls blocks 
+
+
+-- Chunks of static data.
+
+-- We only handle (a) arrays of word-sized things and (b) strings.
+
+pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmString str]) = 
+  hcat [
+    pprLocalness lbl, ptext SLIT("char "), pprCLabel lbl,
+    ptext SLIT("[] = "), pprStringInCStyle str, semi
+  ]
+
+pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmUninitialised size]) = 
+  hcat [
+    pprLocalness lbl, ptext SLIT("char "), pprCLabel lbl,
+    brackets (int size), semi
+  ]
+
+pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) = 
+  pprDataExterns lits $$
+  pprWordArray lbl lits  
+
+-- these shouldn't appear?
+pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data"
+
+
+-- --------------------------------------------------------------------------
+-- BasicBlocks are self-contained entities: they always end in a jump.
+--
+-- Like nativeGen/AsmCodeGen, we could probably reorder blocks to turn
+-- as many jumps as possible into fall throughs.
+--
+
+pprBBlock :: CmmBasicBlock -> SDoc
+pprBBlock (BasicBlock lbl stmts) = 
+    if null stmts then
+        pprTrace "pprC.pprBBlock: curious empty code block for" 
+                        (pprBlockId lbl) empty
+    else 
+        nest 4 (pprBlockId lbl <> colon) $$
+        nest 8 (vcat (map pprStmt stmts))
+
+-- --------------------------------------------------------------------------
+-- Info tables. Just arrays of words. 
+-- See codeGen/ClosureInfo, and nativeGen/PprMach
+
+pprWordArray :: CLabel -> [CmmStatic] -> SDoc
+pprWordArray lbl ds
+  = hcat [ pprLocalness lbl, ptext SLIT("StgWord")
+         , space, pprCLabel lbl, ptext SLIT("[] = {") ] 
+    $$ nest 8 (commafy (pprStatics ds))
+    $$ ptext SLIT("};")
+
+--
+-- has to be static, if it isn't globally visible
+--
+pprLocalness :: CLabel -> SDoc
+pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext SLIT("static ")
+                 | otherwise = empty
+
+-- --------------------------------------------------------------------------
+-- Statements.
+--
+
+pprStmt :: CmmStmt -> SDoc
+
+pprStmt stmt = case stmt of
+    CmmNop       -> empty
+    CmmComment s -> (hang (ptext SLIT("/*")) 3 (ftext s)) $$ ptext SLIT("*/")
+
+    CmmAssign dest src -> pprAssign dest src
+
+    CmmStore  dest src
+	| rep == I64 && wordRep /= I64
+	-> ptext SLIT("ASSIGN_Word64") <> 
+		parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
+
+	| rep == F64 && wordRep /= I64
+	-> ptext SLIT("ASSIGN_DBL") <> 
+		parens (mkP_ <> pprExpr1 dest <> comma <> pprExpr src) <> semi
+
+ 	| otherwise
+	-> hsep [ pprExpr (CmmLoad dest rep), equals, pprExpr src <> semi ]
+	where
+	  rep = cmmExprRep src
+
+    CmmCall (CmmForeignCall fn cconv) results args volatile -> 
+	-- Controversial: leave this out for now.
+	-- pprUndef fn $$
+
+	pprCall ppr_fn cconv results args volatile
+	where
+    	ppr_fn = case fn of
+		   CmmLit (CmmLabel lbl) -> pprCLabel lbl
+		   _other -> parens (cCast (pprCFunType cconv results args) fn)
+			-- for a dynamic call, cast the expression to
+			-- a function of the right type (we hope).
+
+	-- we #undef a function before calling it: the FFI is supposed to be
+	-- an interface specifically to C, not to C+CPP.  For one thing, this
+	-- makes the via-C route more compatible with the NCG.  If macros
+	-- are being used for optimisation, then inline functions are probably
+	-- better anyway.
+	pprUndef (CmmLit (CmmLabel lbl)) = 
+	   ptext SLIT("#undef") <+> pprCLabel lbl
+	pprUndef _ = empty
+
+    CmmCall (CmmPrim op) results args volatile -> 
+	pprCall ppr_fn CCallConv results args volatile
+	where
+    	ppr_fn = pprCallishMachOp_for_C op
+
+    CmmBranch ident          -> pprBranch ident
+    CmmCondBranch expr ident -> pprCondBranch expr ident
+    CmmJump lbl _params      -> mkJMP_(pprExpr lbl) <> semi
+    CmmSwitch arg ids        -> pprSwitch arg ids
+
+pprCFunType :: CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc
+pprCFunType cconv ress args
+  = hcat [
+	res_type ress,
+	parens (text (ccallConvAttribute cconv) <>  char '*'),
+	parens (commafy (map arg_type args))
+   ]
+  where
+	res_type [] = ptext SLIT("void")
+	res_type [(one,hint)] = machRepHintCType (cmmRegRep one) hint
+
+	arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint
+
+-- ---------------------------------------------------------------------
+-- unconditional branches
+pprBranch :: BlockId -> SDoc
+pprBranch ident = ptext SLIT("goto") <+> pprBlockId ident <> semi
+
+
+-- ---------------------------------------------------------------------
+-- conditional branches to local labels
+pprCondBranch :: CmmExpr -> BlockId -> SDoc
+pprCondBranch expr ident 
+        = hsep [ ptext SLIT("if") , parens(pprExpr expr) ,
+                        ptext SLIT("goto") , (pprBlockId ident) <> semi ]
+
+
+-- ---------------------------------------------------------------------
+-- a local table branch
+--
+-- we find the fall-through cases
+--
+-- N.B. we remove Nothing's from the list of branches, as they are
+-- 'undefined'. However, they may be defined one day, so we better
+-- document this behaviour.
+--
+pprSwitch :: CmmExpr -> [ Maybe BlockId ] -> SDoc
+pprSwitch e maybe_ids 
+  = let pairs  = [ (ix, ident) | (ix,Just ident) <- zip [0..] maybe_ids ]
+	pairs2 = [ (map fst as, snd (head as)) | as <- groupBy sndEq pairs ]
+    in 
+        (hang (ptext SLIT("switch") <+> parens ( pprExpr e ) <+> lbrace)
+                4 (vcat ( map caseify pairs2 )))
+        $$ rbrace
+
+  where
+    sndEq (_,x) (_,y) = x == y
+
+    -- fall through case
+    caseify (ix:ixs, ident) = vcat (map do_fallthrough ixs) $$ final_branch ix
+	where 
+	do_fallthrough ix =
+                 hsep [ ptext SLIT("case") , pprHexVal ix wordRep <> colon ,
+                        ptext SLIT("/* fall through */") ]
+
+	final_branch ix = 
+	        hsep [ ptext SLIT("case") , pprHexVal ix wordRep <> colon ,
+                       ptext SLIT("goto") , (pprBlockId ident) <> semi ]
+
+-- ---------------------------------------------------------------------
+-- Expressions.
+--
+
+-- C Types: the invariant is that the C expression generated by
+--
+--	pprExpr e
+--
+-- has a type in C which is also given by
+--
+--	machRepCType (cmmExprRep e)
+--
+-- (similar invariants apply to the rest of the pretty printer).
+
+pprExpr :: CmmExpr -> SDoc
+pprExpr e = case e of
+    CmmLit lit -> pprLit lit
+
+    CmmLoad e I64 | wordRep /= I64
+	-> ptext SLIT("PK_Word64") <> parens (mkP_ <> pprExpr1 e)
+
+    CmmLoad e F64 | wordRep /= I64
+	-> ptext SLIT("PK_DBL") <> parens (mkP_ <> pprExpr1 e)
+
+    CmmLoad (CmmReg r) rep 
+	| isPtrReg r && rep == wordRep
+	-> char '*' <> pprAsPtrReg r
+
+    CmmLoad (CmmRegOff r 0) rep 
+	| isPtrReg r && rep == wordRep
+	-> char '*' <> pprAsPtrReg r
+
+    CmmLoad (CmmRegOff r off) rep
+	| isPtrReg r && rep == wordRep 
+	-- ToDo: check that the offset is a word multiple?
+	-> pprAsPtrReg r <> brackets (ppr (off `shiftR` wordShift))
+
+    CmmLoad expr rep ->
+	-- the general case:
+	char '*' <> parens (cCast (machRepPtrCType rep) expr)
+
+    CmmReg reg      -> pprCastReg reg
+    CmmRegOff reg 0 -> pprCastReg reg
+
+    CmmRegOff reg i
+	| i >  0    -> pprRegOff (char '+') i
+	| otherwise -> pprRegOff (char '-') (-i)
+      where
+	pprRegOff op i' = pprCastReg reg <> op <> int i'
+
+    CmmMachOp mop args -> pprMachOpApp mop args
+
+pprExpr1 :: CmmExpr -> SDoc
+pprExpr1 (CmmLit lit) 	  = pprLit1 lit
+pprExpr1 e@(CmmReg _reg)  = pprExpr e
+pprExpr1 other            = parens (pprExpr other)
+
+-- --------------------------------------------------------------------------
+-- MachOp applications
+
+pprMachOpApp :: MachOp -> [CmmExpr] -> SDoc
+
+pprMachOpApp op args
+  | isMulMayOfloOp op
+  = ptext SLIT("mulIntMayOflo") <> parens (commafy (map pprExpr args))
+  where isMulMayOfloOp (MO_U_MulMayOflo _) = True
+	isMulMayOfloOp (MO_S_MulMayOflo _) = True
+	isMulMayOfloOp _ = False
+
+pprMachOpApp mop args
+ = case args of
+    -- dyadic
+    [x,y] -> pprArg x <+> pprMachOp_for_C mop <+> pprArg y
+
+    -- unary
+    [x]   -> pprMachOp_for_C mop <> parens (pprArg x)
+
+    _     -> panic "PprC.pprMachOp : machop with wrong number of args"
+
+  where
+    pprArg e | signedOp mop = cCast (machRepSignedCType (cmmExprRep e)) e
+ 	     | otherwise    = pprExpr1 e
+
+-- --------------------------------------------------------------------------
+-- Literals
+
+pprLit :: CmmLit -> SDoc
+pprLit lit = case lit of
+    CmmInt i rep      -> pprHexVal i rep
+    CmmFloat f rep     -> parens (machRepCType rep) <> (rational f)
+    CmmLabel clbl      -> mkW_ <> pprCLabelAddr clbl
+    CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i
+    CmmLabelDiffOff clbl1 clbl2 i
+        -- WARNING:
+        --  * the lit must occur in the info table clbl2
+        --  * clbl1 must be an SRT, a slow entry point or a large bitmap
+        -- The Mangler is expected to convert any reference to an SRT,
+        -- a slow entry point or a large bitmap
+        -- from an info table to an offset.
+        -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i
+
+pprCLabelAddr lbl = char '&' <> pprCLabel lbl
+
+pprLit1 :: CmmLit -> SDoc
+pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmLabelDiffOff _ _ _) = parens (pprLit lit)
+pprLit1 lit@(CmmFloat _ _)    = parens (pprLit lit)
+pprLit1 other = pprLit other
+
+-- ---------------------------------------------------------------------------
+-- Static data
+
+pprStatics :: [CmmStatic] -> [SDoc]
+pprStatics [] = []
+pprStatics (CmmStaticLit (CmmFloat f F32) : rest) 
+  = pprLit1 (floatToWord f) : pprStatics rest
+pprStatics (CmmStaticLit (CmmFloat f F64) : rest)
+  = map pprLit1 (doubleToWords f) ++ pprStatics rest
+pprStatics (CmmStaticLit (CmmInt i I64) : rest)
+  | machRepByteWidth I32 == wORD_SIZE
+#ifdef WORDS_BIGENDIAN
+  = pprStatics (CmmStaticLit (CmmInt q I32) : 
+		CmmStaticLit (CmmInt r I32) : rest)
+#else
+  = pprStatics (CmmStaticLit (CmmInt r I32) : 
+		CmmStaticLit (CmmInt q I32) : rest)
+#endif
+  where r = i .&. 0xffffffff
+	q = i `shiftR` 32
+pprStatics (CmmStaticLit lit : rest)
+  = pprLit1 lit : pprStatics rest
+pprStatics (other : rest)
+  = pprPanic "pprWord" (pprStatic other)
+
+pprStatic :: CmmStatic -> SDoc
+pprStatic s = case s of
+
+    CmmStaticLit lit   -> nest 4 (pprLit lit)
+    CmmAlign i         -> nest 4 (ptext SLIT("/* align */") <+> int i)
+    CmmDataLabel clbl  -> pprCLabel clbl <> colon
+    CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i))
+
+    -- these should be inlined, like the old .hc
+    CmmString s'       -> nest 4 (mkW_ <> parens(pprStringInCStyle s'))
+
+
+-- ---------------------------------------------------------------------------
+-- Block Ids
+
+pprBlockId :: BlockId -> SDoc
+pprBlockId b = char '_' <> ppr (getUnique b)
+
+-- --------------------------------------------------------------------------
+-- Print a MachOp in a way suitable for emitting via C.
+--
+
+pprMachOp_for_C :: MachOp -> SDoc
+
+pprMachOp_for_C mop = case mop of 
+
+        -- Integer operations
+        MO_Add          _ -> char '+'
+        MO_Sub          _ -> char '-'
+        MO_Eq           _ -> ptext SLIT("==")
+        MO_Ne           _ -> ptext SLIT("!=")
+        MO_Mul          _ -> char '*'
+
+        MO_S_Quot       _ -> char '/'
+        MO_S_Rem        _ -> char '%'
+        MO_S_Neg        _ -> char '-'
+
+        MO_U_Quot       _ -> char '/'
+        MO_U_Rem        _ -> char '%'
+
+        -- Signed comparisons (floating-point comparisons also use these)
+        -- & Unsigned comparisons
+        MO_S_Ge         _ -> ptext SLIT(">=")
+        MO_S_Le         _ -> ptext SLIT("<=")
+        MO_S_Gt         _ -> char '>'
+        MO_S_Lt         _ -> char '<'
+
+        MO_U_Ge         _ -> ptext SLIT(">=")
+        MO_U_Le         _ -> ptext SLIT("<=")
+        MO_U_Gt         _ -> char '>'
+        MO_U_Lt         _ -> char '<'
+
+        -- Bitwise operations.  Not all of these may be supported at all
+        -- sizes, and only integral MachReps are valid.
+        MO_And          _ -> char '&'
+        MO_Or           _ -> char '|'
+        MO_Xor          _ -> char '^'
+        MO_Not          _ -> char '~'
+        MO_Shl          _ -> ptext SLIT("<<")
+        MO_U_Shr        _ -> ptext SLIT(">>") -- unsigned shift right
+        MO_S_Shr        _ -> ptext SLIT(">>") -- signed shift right
+
+-- Conversions.  Some of these will be NOPs.
+-- Floating-point conversions use the signed variant.
+-- We won't know to generate (void*) casts here, but maybe from
+-- context elsewhere
+
+-- noop casts
+        MO_U_Conv I8 I8     -> empty
+        MO_U_Conv I16 I16   -> empty
+        MO_U_Conv I32 I32   -> empty
+        MO_U_Conv I64 I64   -> empty
+        MO_U_Conv I128 I128 -> empty
+        MO_S_Conv I8 I8     -> empty
+        MO_S_Conv I16 I16   -> empty
+        MO_S_Conv I32 I32   -> empty
+        MO_S_Conv I64 I64   -> empty
+        MO_S_Conv I128 I128 -> empty
+
+	MO_U_Conv _from to  -> parens (machRepCType to)
+	MO_S_Conv _from to  -> parens (machRepSignedCType to)
+
+        _ -> panic "PprC.pprMachOp_for_C: unknown machop"
+
+signedOp :: MachOp -> Bool
+signedOp (MO_S_Quot _)	 = True
+signedOp (MO_S_Rem  _)	 = True
+signedOp (MO_S_Neg  _)	 = True
+signedOp (MO_S_Ge   _)	 = True
+signedOp (MO_S_Le   _)	 = True
+signedOp (MO_S_Gt   _)	 = True
+signedOp (MO_S_Lt   _)	 = True
+signedOp (MO_S_Shr  _)	 = True
+signedOp (MO_S_Conv _ _) = True
+signedOp _ = False
+
+-- ---------------------------------------------------------------------
+-- tend to be implemented by foreign calls
+
+pprCallishMachOp_for_C :: CallishMachOp -> SDoc
+
+pprCallishMachOp_for_C mop 
+    = case mop of
+        MO_F64_Pwr  -> ptext SLIT("pow")
+        MO_F64_Sin  -> ptext SLIT("sin")
+        MO_F64_Cos  -> ptext SLIT("cos")
+        MO_F64_Tan  -> ptext SLIT("tan")
+        MO_F64_Sinh -> ptext SLIT("sinh")
+        MO_F64_Cosh -> ptext SLIT("cosh")
+        MO_F64_Tanh -> ptext SLIT("tanh")
+        MO_F64_Asin -> ptext SLIT("asin")
+        MO_F64_Acos -> ptext SLIT("acos")
+        MO_F64_Atan -> ptext SLIT("atan")
+        MO_F64_Log  -> ptext SLIT("log")
+        MO_F64_Exp  -> ptext SLIT("exp")
+        MO_F64_Sqrt -> ptext SLIT("sqrt")
+        MO_F32_Pwr  -> ptext SLIT("powf")
+        MO_F32_Sin  -> ptext SLIT("sinf")
+        MO_F32_Cos  -> ptext SLIT("cosf")
+        MO_F32_Tan  -> ptext SLIT("tanf")
+        MO_F32_Sinh -> ptext SLIT("sinhf")
+        MO_F32_Cosh -> ptext SLIT("coshf")
+        MO_F32_Tanh -> ptext SLIT("tanhf")
+        MO_F32_Asin -> ptext SLIT("asinf")
+        MO_F32_Acos -> ptext SLIT("acosf")
+        MO_F32_Atan -> ptext SLIT("atanf")
+        MO_F32_Log  -> ptext SLIT("logf")
+        MO_F32_Exp  -> ptext SLIT("expf")
+        MO_F32_Sqrt -> ptext SLIT("sqrtf")
+
+-- ---------------------------------------------------------------------
+-- Useful #defines
+--
+
+mkJMP_, mkFN_, mkIF_ :: SDoc -> SDoc
+
+mkJMP_ i = ptext SLIT("JMP_") <> parens i
+mkFN_  i = ptext SLIT("FN_")  <> parens i -- externally visible function
+mkIF_  i = ptext SLIT("IF_")  <> parens i -- locally visible
+
+
+mkFB_, mkFE_ :: SDoc
+mkFB_ = ptext SLIT("FB_") -- function code begin
+mkFE_ = ptext SLIT("FE_") -- function code end
+
+-- from includes/Stg.h
+--
+mkC_,mkW_,mkP_,mkPP_,mkI_,mkA_,mkD_,mkF_,mkB_,mkL_,mkLI_,mkLW_ :: SDoc
+
+mkC_  = ptext SLIT("(C_)")        -- StgChar
+mkW_  = ptext SLIT("(W_)")        -- StgWord
+mkP_  = ptext SLIT("(P_)")        -- StgWord*
+mkPP_ = ptext SLIT("(PP_)")       -- P_*
+mkI_  = ptext SLIT("(I_)")        -- StgInt
+mkA_  = ptext SLIT("(A_)")        -- StgAddr
+mkD_  = ptext SLIT("(D_)")        -- const StgWord*
+mkF_  = ptext SLIT("(F_)")        -- StgFunPtr
+mkB_  = ptext SLIT("(B_)")        -- StgByteArray
+mkL_  = ptext SLIT("(L_)")        -- StgClosurePtr
+
+mkLI_ = ptext SLIT("(LI_)")       -- StgInt64
+mkLW_ = ptext SLIT("(LW_)")       -- StgWord64
+
+
+-- ---------------------------------------------------------------------
+--
+-- Assignments
+--
+-- Generating assignments is what we're all about, here
+--
+pprAssign :: CmmReg -> CmmExpr -> SDoc
+
+-- dest is a reg, rhs is a reg
+pprAssign r1 (CmmReg r2)
+   | not (isStrangeTypeReg r1) && not (isStrangeTypeReg r2)
+   || isPtrReg r1 && isPtrReg r2
+   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, semi ]
+
+-- dest is a reg, rhs is a CmmRegOff
+pprAssign r1 (CmmRegOff r2 off)
+   | not (isStrangeTypeReg r1) && not (isStrangeTypeReg r2)
+   || isPtrReg r1 && isPtrReg r2
+   = hcat [ pprAsPtrReg r1, equals, pprAsPtrReg r2, op, int off', semi ]
+  where
+	off1 | isPtrReg r2 = off `shiftR` wordShift
+	     | otherwise   = off
+
+	(op,off') | off >= 0  = (char '+', off1)
+		  | otherwise = (char '-', -off1)
+
+-- dest is a reg, rhs is anything.
+-- We can't cast the lvalue, so we have to cast the rhs if necessary.  Casting
+-- the lvalue elicits a warning from new GCC versions (3.4+).
+pprAssign r1 r2
+  | isPtrReg r1
+  = pprAsPtrReg r1 <> ptext SLIT(" = ") <> mkP_ <> pprExpr1 r2 <> semi
+  | Just ty <- strangeRegType r1
+  = pprReg r1 <> ptext SLIT(" = ") <> parens ty <> pprExpr1 r2 <> semi
+  | otherwise
+  = pprReg r1 <> ptext SLIT(" = ") <> pprExpr r2 <> semi
+
+-- ---------------------------------------------------------------------
+-- Registers
+
+pprCastReg reg
+   | isStrangeTypeReg reg = mkW_ <> pprReg reg
+   | otherwise            = pprReg reg
+
+-- True if the register has type StgPtr in C, otherwise it has an
+-- integer type.  We need to take care with pointer arithmetic on registers
+-- with type StgPtr.
+isPtrReg :: CmmReg -> Bool
+isPtrReg (CmmLocal _) = False
+isPtrReg (CmmGlobal r) = isPtrGlobalReg r
+
+isPtrGlobalReg :: GlobalReg -> Bool
+isPtrGlobalReg (VanillaReg n) 	= True
+isPtrGlobalReg Sp 		= True
+isPtrGlobalReg Hp 		= True
+isPtrGlobalReg HpLim 		= True
+isPtrGlobalReg SpLim 		= True
+isPtrGlobalReg _ 		= False
+
+-- True if in C this register doesn't have the type given by 
+-- (machRepCType (cmmRegRep reg)), so it has to be cast.
+isStrangeTypeReg :: CmmReg -> Bool
+isStrangeTypeReg (CmmLocal _) 	= False
+isStrangeTypeReg (CmmGlobal g) 	= isStrangeTypeGlobal g
+
+isStrangeTypeGlobal :: GlobalReg -> Bool
+isStrangeTypeGlobal CurrentTSO		= True
+isStrangeTypeGlobal CurrentNursery 	= True
+isStrangeTypeGlobal BaseReg	 	= True
+isStrangeTypeGlobal r 			= isPtrGlobalReg r
+
+strangeRegType :: CmmReg -> Maybe SDoc
+strangeRegType (CmmGlobal CurrentTSO) = Just (ptext SLIT("struct StgTSO_ *"))
+strangeRegType (CmmGlobal CurrentNursery) = Just (ptext SLIT("struct bdescr_ *"))
+strangeRegType (CmmGlobal BaseReg) = Just (ptext SLIT("struct StgRegTable_ *"))
+strangeRegType _ = Nothing
+
+-- pprReg just prints the register name.
+--
+pprReg :: CmmReg -> SDoc
+pprReg r = case r of
+        CmmLocal  local  -> pprLocalReg local
+        CmmGlobal global -> pprGlobalReg global
+		
+pprAsPtrReg :: CmmReg -> SDoc
+pprAsPtrReg (CmmGlobal (VanillaReg n)) = char 'R' <> int n <> ptext SLIT(".p")
+pprAsPtrReg other_reg = pprReg other_reg
+
+pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg gr = case gr of
+    VanillaReg n   -> char 'R' <> int n  <> ptext SLIT(".w")
+    FloatReg   n   -> char 'F' <> int n
+    DoubleReg  n   -> char 'D' <> int n
+    LongReg    n   -> char 'L' <> int n
+    Sp             -> ptext SLIT("Sp")
+    SpLim          -> ptext SLIT("SpLim")
+    Hp             -> ptext SLIT("Hp")
+    HpLim          -> ptext SLIT("HpLim")
+    CurrentTSO     -> ptext SLIT("CurrentTSO")
+    CurrentNursery -> ptext SLIT("CurrentNursery")
+    HpAlloc        -> ptext SLIT("HpAlloc")
+    BaseReg        -> ptext SLIT("BaseReg")
+    GCEnter1       -> ptext SLIT("stg_gc_enter_1")
+    GCFun          -> ptext SLIT("stg_gc_fun")
+
+pprLocalReg :: LocalReg -> SDoc
+pprLocalReg (LocalReg uniq _rep) = char '_' <> ppr uniq
+
+-- -----------------------------------------------------------------------------
+-- Foreign Calls
+
+pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)]
+	-> Maybe [GlobalReg] -> SDoc
+
+pprCall ppr_fn cconv results args vols
+  | not (is_cish cconv)
+  = panic "pprCall: unknown calling convention"
+
+  | otherwise
+  = save vols $$
+    ptext SLIT("CALLER_SAVE_SYSTEM") $$
+#if x86_64_TARGET_ARCH
+	-- HACK around gcc optimisations.
+	-- x86_64 needs a __DISCARD__() here, to create a barrier between
+	-- putting the arguments into temporaries and passing the arguments
+	-- to the callee, because the argument expressions may refer to
+	-- machine registers that are also used for passing arguments in the
+	-- C calling convention.
+    (if (not opt_Unregisterised) 
+	then ptext SLIT("__DISCARD__();") 
+	else empty) $$
+#endif
+    ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi $$
+    ptext SLIT("CALLER_RESTORE_SYSTEM") $$
+    restore vols
+  where 
+     ppr_assign []           rhs = rhs
+     ppr_assign [(reg@(CmmGlobal BaseReg), hint)] rhs
+	 | Just ty <- strangeRegType reg
+	 = ptext SLIT("ASSIGN_BaseReg") <> parens (parens ty <> rhs)
+	 -- BaseReg is special, sometimes it isn't an lvalue and we
+	 -- can't assign to it.
+     ppr_assign [(one,hint)] rhs
+	 | Just ty <- strangeRegType one
+	 = pprReg one <> ptext SLIT(" = ") <> parens ty <> rhs
+	 | otherwise
+	 = pprReg one <> ptext SLIT(" = ")
+		 <> pprUnHint hint (cmmRegRep one) <> rhs
+     ppr_assign _other _rhs = panic "pprCall: multiple results"
+
+     pprArg (expr, PtrHint)
+   	= cCast (ptext SLIT("void *")) expr
+	-- see comment by machRepHintCType below
+     pprArg (expr, SignedHint)
+	= cCast (machRepSignedCType (cmmExprRep expr)) expr
+     pprArg (expr, _other)
+	= pprExpr expr
+
+     pprUnHint PtrHint    rep = parens (machRepCType rep)
+     pprUnHint SignedHint rep = parens (machRepCType rep)
+     pprUnHint _          _   = empty
+
+     save    = save_restore SLIT("CALLER_SAVE")
+     restore = save_restore SLIT("CALLER_RESTORE")
+
+	-- Nothing says "I don't know what's live; save everything"
+	-- CALLER_SAVE_USER is defined in ghc/includes/Regs.h
+     save_restore txt Nothing     = ptext txt <> ptext SLIT("_USER")
+     save_restore txt (Just these) = vcat (map saveRestoreGlobal these)
+	where saveRestoreGlobal r = ptext txt <> char '_' <> pprGlobalRegName r
+
+pprGlobalRegName :: GlobalReg -> SDoc
+pprGlobalRegName gr = case gr of
+    VanillaReg n   -> char 'R' <> int n  -- without the .w suffix
+    _              -> pprGlobalReg gr
+
+-- Currently we only have these two calling conventions, but this might
+-- change in the future...
+is_cish CCallConv   = True
+is_cish StdCallConv = True
+
+-- ---------------------------------------------------------------------
+-- Find and print local and external declarations for a list of
+-- Cmm statements.
+-- 
+pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
+pprTempAndExternDecls stmts 
+  = (vcat (map pprTempDecl (eltsUFM temps)), 
+     vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls)))
+  where (temps, lbls) = runTE (mapM_ te_BB stmts)
+
+pprDataExterns :: [CmmStatic] -> SDoc
+pprDataExterns statics
+  = vcat (map (pprExternDecl False{-ToDo-}) (keysFM lbls))
+  where (_, lbls) = runTE (mapM_ te_Static statics)
+
+pprTempDecl :: LocalReg -> SDoc
+pprTempDecl l@(LocalReg _uniq rep)
+  = hcat [ machRepCType rep, space, pprLocalReg l, semi ]
+
+pprExternDecl :: Bool -> CLabel -> SDoc
+pprExternDecl in_srt lbl
+  -- do not print anything for "known external" things
+  | not (needsCDecl lbl) = empty
+  | otherwise		    = 
+	hcat [ visibility, label_type (labelType lbl), 
+	       lparen, dyn_wrapper (pprCLabel lbl), text ");" ]
+ where
+  dyn_wrapper d
+    | in_srt && labelDynamic lbl = text "DLL_IMPORT_DATA_VAR" <> parens d
+    | otherwise			 = d
+
+  label_type CodeLabel = ptext SLIT("F_")
+  label_type DataLabel = ptext SLIT("I_")
+
+  visibility
+     | externallyVisibleCLabel lbl = char 'E'
+     | otherwise		   = char 'I'
+
+
+type TEState = (UniqSet LocalReg, FiniteMap CLabel ())
+newtype TE a = TE { unTE :: TEState -> (a, TEState) }
+
+instance Monad TE where
+   TE m >>= k  = TE $ \s -> case m s of (a, s') -> unTE (k a) s'
+   return a    = TE $ \s -> (a, s)
+
+te_lbl :: CLabel -> TE ()
+te_lbl lbl = TE $ \(temps,lbls) -> ((), (temps, addToFM lbls lbl ()))
+
+te_temp :: LocalReg -> TE ()
+te_temp r = TE $ \(temps,lbls) -> ((), (addOneToUniqSet temps r, lbls))
+
+runTE :: TE () -> TEState
+runTE (TE m) = snd (m (emptyUniqSet, emptyFM))
+
+te_Static :: CmmStatic -> TE ()
+te_Static (CmmStaticLit lit) = te_Lit lit
+te_Static _ = return ()
+
+te_BB :: CmmBasicBlock -> TE ()
+te_BB (BasicBlock _ ss)		= mapM_ te_Stmt ss
+
+te_Lit :: CmmLit -> TE ()
+te_Lit (CmmLabel l) = te_lbl l
+te_Lit (CmmLabelOff l _) = te_lbl l
+te_Lit (CmmLabelDiffOff l1 l2 _) = te_lbl l1
+te_Lit _ = return ()
+
+te_Stmt :: CmmStmt -> TE ()
+te_Stmt (CmmAssign r e)		= te_Reg r >> te_Expr e
+te_Stmt (CmmStore l r)		= te_Expr l >> te_Expr r
+te_Stmt (CmmCall _ rs es _)	= mapM_ (te_Reg.fst) rs >>
+				  mapM_ (te_Expr.fst) es
+te_Stmt (CmmCondBranch e _)	= te_Expr e
+te_Stmt (CmmSwitch e _)		= te_Expr e
+te_Stmt (CmmJump e _)		= te_Expr e
+te_Stmt _			= return ()
+
+te_Expr :: CmmExpr -> TE ()
+te_Expr (CmmLit lit)		= te_Lit lit
+te_Expr (CmmLoad e _)		= te_Expr e
+te_Expr (CmmReg r)		= te_Reg r
+te_Expr (CmmMachOp _ es) 	= mapM_ te_Expr es
+te_Expr (CmmRegOff r _) 	= te_Reg r
+
+te_Reg :: CmmReg -> TE ()
+te_Reg (CmmLocal l) = te_temp l
+te_Reg _            = return ()
+
+
+-- ---------------------------------------------------------------------
+-- C types for MachReps
+
+cCast :: SDoc -> CmmExpr -> SDoc
+cCast ty expr = parens ty <> pprExpr1 expr
+
+-- This is for finding the types of foreign call arguments.  For a pointer
+-- argument, we always cast the argument to (void *), to avoid warnings from
+-- the C compiler.
+machRepHintCType :: MachRep -> MachHint -> SDoc
+machRepHintCType rep PtrHint    = ptext SLIT("void *")
+machRepHintCType rep SignedHint = machRepSignedCType rep
+machRepHintCType rep _other     = machRepCType rep
+
+machRepPtrCType :: MachRep -> SDoc
+machRepPtrCType r | r == wordRep = ptext SLIT("P_")
+	          | otherwise    = machRepCType r <> char '*'
+
+machRepCType :: MachRep -> SDoc
+machRepCType r | r == wordRep = ptext SLIT("W_")
+	       | otherwise    = sized_type
+  where sized_type = case r of
+			I8	-> ptext SLIT("StgWord8")
+			I16	-> ptext SLIT("StgWord16")
+			I32	-> ptext SLIT("StgWord32")
+			I64	-> ptext SLIT("StgWord64")
+			F32	-> ptext SLIT("StgFloat") -- ToDo: correct?
+			F64	-> ptext SLIT("StgDouble")
+			_  -> panic "machRepCType"
+
+machRepSignedCType :: MachRep -> SDoc
+machRepSignedCType r | r == wordRep = ptext SLIT("I_")
+                     | otherwise    = sized_type
+  where sized_type = case r of
+			I8	-> ptext SLIT("StgInt8")
+			I16	-> ptext SLIT("StgInt16")
+			I32	-> ptext SLIT("StgInt32")
+			I64	-> ptext SLIT("StgInt64")
+			F32	-> ptext SLIT("StgFloat") -- ToDo: correct?
+			F64	-> ptext SLIT("StgDouble")
+			_ -> panic "machRepCType"
+
+-- ---------------------------------------------------------------------
+-- print strings as valid C strings
+
+pprStringInCStyle :: [Word8] -> SDoc
+pprStringInCStyle s = doubleQuotes (text (concatMap charToC s))
+
+charToC :: Word8 -> String
+charToC w = 
+  case chr (fromIntegral w) of
+	'\"' -> "\\\""
+	'\'' -> "\\\'"
+	'\\' -> "\\\\"
+	c | c >= ' ' && c <= '~' -> [c]
+          | otherwise -> ['\\',
+                         chr (ord '0' + ord c `div` 64),
+                         chr (ord '0' + ord c `div` 8 `mod` 8),
+                         chr (ord '0' + ord c         `mod` 8)]
+
+-- ---------------------------------------------------------------------------
+-- Initialising static objects with floating-point numbers.  We can't
+-- just emit the floating point number, because C will cast it to an int
+-- by rounding it.  We want the actual bit-representation of the float.
+
+-- This is a hack to turn the floating point numbers into ints that we
+-- can safely initialise to static locations.
+
+big_doubles 
+  | machRepByteWidth F64 == 2 * wORD_SIZE  = True
+  | machRepByteWidth F64 == wORD_SIZE      = False
+  | otherwise = panic "big_doubles"
+
+#if __GLASGOW_HASKELL__ >= 504
+newFloatArray :: (Int,Int) -> ST s (STUArray s Int Float)
+newFloatArray = newArray_
+
+newDoubleArray :: (Int,Int) -> ST s (STUArray s Int Double)
+newDoubleArray = newArray_
+
+castFloatToIntArray :: STUArray s Int Float -> ST s (STUArray s Int Int)
+castFloatToIntArray = castSTUArray
+
+castDoubleToIntArray :: STUArray s Int Double -> ST s (STUArray s Int Int)
+castDoubleToIntArray = castSTUArray
+
+writeFloatArray :: STUArray s Int Float -> Int -> Float -> ST s ()
+writeFloatArray = writeArray
+
+writeDoubleArray :: STUArray s Int Double -> Int -> Double -> ST s ()
+writeDoubleArray = writeArray
+
+readIntArray :: STUArray s Int Int -> Int -> ST s Int
+readIntArray = readArray
+
+#else
+
+castFloatToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+castFloatToIntArray = return
+
+castDoubleToIntArray :: MutableByteArray s t -> ST s (MutableByteArray s t)
+castDoubleToIntArray = return
+
+#endif
+
+-- floats are always 1 word
+floatToWord :: Rational -> CmmLit
+floatToWord r
+  = runST (do
+	arr <- newFloatArray ((0::Int),0)
+	writeFloatArray arr 0 (fromRational r)
+	arr' <- castFloatToIntArray arr
+	i <- readIntArray arr' 0
+	return (CmmInt (toInteger i) wordRep)
+    )
+
+doubleToWords :: Rational -> [CmmLit]
+doubleToWords r
+  | big_doubles				-- doubles are 2 words
+  = runST (do
+	arr <- newDoubleArray ((0::Int),1)
+	writeDoubleArray arr 0 (fromRational r)
+	arr' <- castDoubleToIntArray arr
+	i1 <- readIntArray arr' 0
+	i2 <- readIntArray arr' 1
+	return [ CmmInt (toInteger i1) wordRep
+	       , CmmInt (toInteger i2) wordRep
+	       ]
+    )
+  | otherwise				-- doubles are 1 word
+  = runST (do
+	arr <- newDoubleArray ((0::Int),0)
+	writeDoubleArray arr 0 (fromRational r)
+	arr' <- castDoubleToIntArray arr
+	i <- readIntArray arr' 0
+	return [ CmmInt (toInteger i) wordRep ]
+    )
+
+-- ---------------------------------------------------------------------------
+-- Utils
+
+wordShift :: Int
+wordShift = machRepLogWidth wordRep
+
+commafy :: [SDoc] -> SDoc
+commafy xs = hsep $ punctuate comma xs
+
+-- Print in C hex format: 0x13fa
+pprHexVal :: Integer -> MachRep -> SDoc
+pprHexVal 0 _ = ptext SLIT("0x0")
+pprHexVal w rep
+  | w < 0     = parens (char '-' <> ptext SLIT("0x") <> go (-w) <> repsuffix rep)
+  | otherwise = ptext SLIT("0x") <> go w <> repsuffix rep
+  where
+  	-- type suffix for literals:
+	-- Integer literals are unsigned in Cmm/C.  We explicitly cast to
+	-- signed values for doing signed operations, but at all other
+	-- times values are unsigned.  This also helps eliminate occasional
+	-- warnings about integer overflow from gcc.
+
+	-- on 32-bit platforms, add "ULL" to 64-bit literals
+      repsuffix I64 | wORD_SIZE == 4 = ptext SLIT("ULL")
+      	-- on 64-bit platforms with 32-bit int, add "L" to 64-bit literals
+      repsuffix I64 | cINT_SIZE == 4 = ptext SLIT("UL")
+      repsuffix _ = char 'U'
+      
+      go 0 = empty
+      go w' = go q <> dig
+           where
+             (q,r) = w' `quotRem` 16
+             dig | r < 10    = char (chr (fromInteger r + ord '0'))
+                 | otherwise = char (chr (fromInteger r - 10 + ord 'a'))
+
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
new file mode 100644
index 0000000000..6e8367d662
--- /dev/null
+++ b/compiler/cmm/PprCmm.hs
@@ -0,0 +1,462 @@
+----------------------------------------------------------------------------
+--
+-- Pretty-printing of Cmm as (a superset of) C--
+--
+-- (c) The University of Glasgow 2004
+--
+-----------------------------------------------------------------------------
+
+--
+-- This is where we walk over Cmm emitting an external representation,
+-- suitable for parsing, in a syntax strongly reminiscent of C--. This
+-- is the "External Core" for the Cmm layer.
+--
+-- As such, this should be a well-defined syntax: we want it to look nice.
+-- Thus, we try wherever possible to use syntax defined in [1],
+-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
+-- slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- than C--'s bits8 .. bits64.
+--
+-- We try to ensure that all information available in the abstract
+-- syntax is reproduced, or reproducible, in the concrete syntax.
+-- Data that is not in printed out can be reconstructed according to
+-- conventions used in the pretty printer. There are at least two such
+-- cases:
+--      1) if a value has wordRep type, the type is not appended in the
+--      output.
+--      2) MachOps that operate over wordRep type are printed in a
+--      C-style, rather than as their internal MachRep name.
+--
+-- These conventions produce much more readable Cmm output.
+--
+-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
+--
+
+module PprCmm ( 	
+	writeCmms, pprCmms, pprCmm, pprStmt, pprExpr
+  ) where
+
+#include "HsVersions.h"
+
+import Cmm
+import CmmUtils     ( isTrivialCmmExpr )
+import MachOp       ( MachOp(..), pprMachOp, MachRep(..), wordRep )
+import CLabel       ( pprCLabel, mkForeignLabel, entryLblToInfoLbl )
+
+import ForeignCall  ( CCallConv(..) )
+import Unique       ( getUnique )
+import Outputable
+import FastString   ( mkFastString )
+
+import Data.List    ( intersperse, groupBy )
+import IO           ( Handle )
+import Maybe	    ( isJust )
+import Data.Char    ( chr )
+
+pprCmms :: [Cmm] -> SDoc
+pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
+        where
+          separator = space $$ ptext SLIT("-------------------") $$ space
+
+writeCmms :: Handle -> [Cmm] -> IO ()
+writeCmms handle cmms = printForC handle (pprCmms cmms)
+
+-----------------------------------------------------------------------------
+
+instance Outputable Cmm where
+    ppr c = pprCmm c
+
+instance Outputable CmmTop where
+    ppr t = pprTop t
+
+instance Outputable CmmBasicBlock where
+    ppr b = pprBBlock b
+
+instance Outputable CmmStmt where
+    ppr s = pprStmt s
+
+instance Outputable CmmExpr where
+    ppr e = pprExpr e
+
+instance Outputable CmmReg where
+    ppr e = pprReg e
+
+instance Outputable GlobalReg where
+    ppr e = pprGlobalReg e
+
+-----------------------------------------------------------------------------
+
+pprCmm :: Cmm -> SDoc
+pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
+
+-- --------------------------------------------------------------------------
+-- Top level `procedure' blocks. The info tables, if not null, are
+-- printed in the style of C--'s 'stackdata' declaration, just inside
+-- the proc body, and are labelled with the procedure name ++ "_info".
+--
+pprTop :: CmmTop -> SDoc
+pprTop (CmmProc info lbl params blocks )
+
+  = vcat [ pprCLabel lbl <> parens (commafy $ map pprLocalReg params) <+> lbrace
+         , nest 8 $ pprInfo info lbl
+         , nest 4 $ vcat (map ppr blocks)
+         , rbrace ]
+
+  where
+    pprInfo [] _  = empty
+    pprInfo i label = 
+        (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace )
+            4 $ vcat (map pprStatic i))
+        $$ rbrace
+
+-- --------------------------------------------------------------------------
+-- We follow [1], 4.5
+--
+--      section "data" { ... }
+--
+pprTop (CmmData section ds) = 
+    (hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
+    $$ rbrace
+
+
+-- --------------------------------------------------------------------------
+-- Basic blocks look like assembly blocks.
+--      lbl: stmt ; stmt ; .. 
+pprBBlock :: CmmBasicBlock -> SDoc
+pprBBlock (BasicBlock ident stmts) =
+    hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts))
+
+-- --------------------------------------------------------------------------
+-- Statements. C-- usually, exceptions to this should be obvious.
+--
+pprStmt :: CmmStmt -> SDoc    
+pprStmt stmt = case stmt of
+
+    -- ;
+    CmmNop -> semi
+
+    --  // text
+    CmmComment s -> text "//" <+> ftext s
+
+    -- reg = expr;
+    CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
+
+    -- rep[lv] = expr;
+    CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
+        where
+          rep = ppr ( cmmExprRep expr )
+
+    -- call "ccall" foo(x, y)[r1, r2];
+    -- ToDo ppr volatile
+    CmmCall (CmmForeignCall fn cconv) results args _volatile ->
+        hcat [ ptext SLIT("call"), space, 
+               doubleQuotes(ppr cconv), space,
+               target fn, parens  ( commafy $ map ppr args ),
+               (if null results
+                    then empty
+                    else brackets( commafy $ map ppr results)), semi ]
+        where
+            target (CmmLit lit) = pprLit lit
+            target fn'          = parens (ppr fn')
+
+    CmmCall (CmmPrim op) results args volatile ->
+        pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
+                        results args volatile)
+        where
+          lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
+
+    CmmBranch ident          -> genBranch ident
+    CmmCondBranch expr ident -> genCondBranch expr ident
+    CmmJump expr params      -> genJump expr params
+    CmmSwitch arg ids        -> genSwitch arg ids
+
+-- --------------------------------------------------------------------------
+-- goto local label. [1], section 6.6
+--
+--     goto lbl;
+--
+genBranch :: BlockId -> SDoc
+genBranch ident = 
+    ptext SLIT("goto") <+> pprBlockId ident <> semi
+
+-- --------------------------------------------------------------------------
+-- Conditional. [1], section 6.4
+--
+--     if (expr) { goto lbl; } 
+--
+genCondBranch :: CmmExpr -> BlockId -> SDoc
+genCondBranch expr ident =
+    hsep [ ptext SLIT("if")
+         , parens(ppr expr)
+         , ptext SLIT("goto")
+         , pprBlockId ident <> semi ]
+
+-- --------------------------------------------------------------------------
+-- A tail call. [1], Section 6.9
+--
+--     jump foo(a, b, c);
+--
+genJump :: CmmExpr -> [LocalReg] -> SDoc
+genJump expr actuals = 
+
+    hcat [ ptext SLIT("jump")
+         , space
+         , if isTrivialCmmExpr expr
+                then pprExpr expr
+                else case expr of
+                    CmmLoad (CmmReg _) _ -> pprExpr expr 
+                    _ -> parens (pprExpr expr)
+         , pprActuals actuals
+         , semi ]
+
+  where
+    pprActuals [] = empty
+    pprActuals as = parens ( commafy $ map pprLocalReg as ) 
+
+-- --------------------------------------------------------------------------
+-- Tabled jump to local label
+--
+-- The syntax is from [1], section 6.5
+--
+--      switch [0 .. n] (expr) { case ... ; }
+--
+genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
+genSwitch expr maybe_ids 
+
+    = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
+
+      in hang (hcat [ ptext SLIT("switch [0 .. ") 
+                    , int (length maybe_ids - 1)
+                    , ptext SLIT("] ")
+                    , if isTrivialCmmExpr expr
+                        then pprExpr expr
+                        else parens (pprExpr expr)
+                    , ptext SLIT(" {") 
+                    ]) 
+            4 (vcat ( map caseify pairs )) $$ rbrace
+
+    where
+      snds a b = (snd a) == (snd b)
+
+      caseify :: [(Int,Maybe BlockId)] -> SDoc
+      caseify ixs@((i,Nothing):_)
+        = ptext SLIT("/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
+		<> ptext SLIT(" */")
+      caseify as 
+        = let (is,ids) = unzip as 
+          in hsep [ ptext SLIT("case")
+                  , hcat (punctuate comma (map int is))
+                  , ptext SLIT(": goto")
+                  , pprBlockId (head [ id | Just id <- ids]) <> semi ]
+
+-- --------------------------------------------------------------------------
+-- Expressions
+--
+
+pprExpr :: CmmExpr -> SDoc
+pprExpr e 
+    = case e of
+        CmmRegOff reg i -> 
+		pprExpr (CmmMachOp (MO_Add rep)
+			   [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
+		where rep = cmmRegRep reg	
+	CmmLit lit -> pprLit lit
+	_other     -> pprExpr1 e
+
+-- Here's the precedence table from CmmParse.y:
+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
+-- %left '|'
+-- %left '^'
+-- %left '&'
+-- %left '>>' '<<'
+-- %left '-' '+'
+-- %left '/' '*' '%'
+-- %right '~'
+
+-- We just cope with the common operators for now, the rest will get
+-- a default conservative behaviour.
+
+-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
+pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
+   = pprExpr7 x <+> doc <+> pprExpr7 y
+pprExpr1 e = pprExpr7 e
+
+infixMachOp1 (MO_Eq     _) = Just (ptext SLIT("=="))
+infixMachOp1 (MO_Ne     _) = Just (ptext SLIT("!="))
+infixMachOp1 (MO_Shl    _) = Just (ptext SLIT("<<"))
+infixMachOp1 (MO_U_Shr  _) = Just (ptext SLIT(">>"))
+infixMachOp1 (MO_U_Ge   _) = Just (ptext SLIT(">="))
+infixMachOp1 (MO_U_Le   _) = Just (ptext SLIT("<="))
+infixMachOp1 (MO_U_Gt   _) = Just (char '>')
+infixMachOp1 (MO_U_Lt   _) = Just (char '<')
+infixMachOp1 _             = Nothing
+
+-- %left '-' '+'
+pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
+   = pprExpr7 x <+> doc <+> pprExpr8 y
+pprExpr7 e = pprExpr8 e
+
+infixMachOp7 (MO_Add _)  = Just (char '+')
+infixMachOp7 (MO_Sub _)  = Just (char '-')
+infixMachOp7 _           = Nothing
+
+-- %left '/' '*' '%'
+pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
+   = pprExpr8 x <+> doc <+> pprExpr9 y
+pprExpr8 e = pprExpr9 e
+
+infixMachOp8 (MO_U_Quot _) = Just (char '/')
+infixMachOp8 (MO_Mul _)    = Just (char '*')
+infixMachOp8 (MO_U_Rem _)  = Just (char '%')
+infixMachOp8 _             = Nothing
+
+pprExpr9 :: CmmExpr -> SDoc
+pprExpr9 e = 
+   case e of
+        CmmLit    lit       -> pprLit1 lit
+        CmmLoad   expr rep  -> ppr rep <> brackets( ppr expr )
+        CmmReg    reg       -> ppr reg
+        CmmRegOff reg off   -> parens (ppr reg <+> char '+' <+> int off)
+	CmmMachOp mop args  -> genMachOp mop args
+
+genMachOp :: MachOp -> [CmmExpr] -> SDoc
+genMachOp mop args
+   | Just doc <- infixMachOp mop = case args of
+        -- dyadic
+        [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
+
+        -- unary
+        [x]   -> doc <> pprExpr9 x
+
+        _     -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
+                          (pprMachOp mop <+>
+                            parens (hcat $ punctuate comma (map pprExpr args)))
+                          empty
+
+   | isJust (infixMachOp1 mop)
+   || isJust (infixMachOp7 mop)
+   || isJust (infixMachOp8 mop)	 = parens (pprExpr (CmmMachOp mop args))
+
+   | otherwise = char '%' <> pprMachOp mop <> parens (commafy (map pprExpr args))
+
+--
+-- Unsigned ops on the word size of the machine get nice symbols.
+-- All else get dumped in their ugly format.
+--
+infixMachOp :: MachOp -> Maybe SDoc
+infixMachOp mop
+	= case mop of
+            MO_And    _ -> Just $ char '&'
+            MO_Or     _ -> Just $ char '|'
+            MO_Xor    _ -> Just $ char '^'
+            MO_Not    _ -> Just $ char '~'
+            MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)
+            _ -> Nothing
+
+-- --------------------------------------------------------------------------
+-- Literals.
+--  To minimise line noise we adopt the convention that if the literal
+--  has the natural machine word size, we do not append the type
+--
+pprLit :: CmmLit -> SDoc
+pprLit lit = case lit of
+    CmmInt i rep ->
+        hcat [ (if i < 0 then parens else id)(integer i)
+             , (if rep == wordRep 
+                    then empty 
+                    else space <> dcolon <+> ppr rep) ]
+
+    CmmFloat f rep     -> hsep [ rational f, dcolon, ppr rep ]
+    CmmLabel clbl      -> pprCLabel clbl
+    CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
+    CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'  
+                                  <> pprCLabel clbl2 <> ppr_offset i
+
+pprLit1 lit@(CmmLabelOff clbl i) = parens (pprLit lit)
+pprLit1 lit                      = pprLit lit
+
+ppr_offset :: Int -> SDoc
+ppr_offset i
+    | i==0      = empty
+    | i>=0      = char '+' <> int i
+    | otherwise = char '-' <> int (-i)
+
+-- --------------------------------------------------------------------------
+-- Static data.
+--      Strings are printed as C strings, and we print them as I8[],
+--      following C--
+--
+pprStatic :: CmmStatic -> SDoc
+pprStatic s = case s of
+    CmmStaticLit lit   -> nest 4 $ ptext SLIT("const") <+> pprLit lit <> semi
+    CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
+    CmmAlign i         -> nest 4 $ text "align" <+> int i
+    CmmDataLabel clbl  -> pprCLabel clbl <> colon
+    CmmString s'       -> nest 4 $ text "I8[]" <+> 
+			   doubleQuotes (text (map (chr.fromIntegral) s'))
+
+-- --------------------------------------------------------------------------
+-- Registers, whether local (temps) or global
+--
+pprReg :: CmmReg -> SDoc
+pprReg r 
+    = case r of
+        CmmLocal  local  -> pprLocalReg local
+        CmmGlobal global -> pprGlobalReg global
+
+--
+-- We only print the type of the local reg if it isn't wordRep
+--
+pprLocalReg :: LocalReg -> SDoc
+pprLocalReg (LocalReg uniq rep) 
+    = hcat [ char '_', ppr uniq, 
+            (if rep == wordRep 
+                then empty else dcolon <> ppr rep) ]
+
+-- needs to be kept in syn with Cmm.hs.GlobalReg
+--
+pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg gr 
+    = case gr of
+        VanillaReg n   -> char 'R' <> int n
+        FloatReg   n   -> char 'F' <> int n
+        DoubleReg  n   -> char 'D' <> int n
+        LongReg    n   -> char 'L' <> int n
+        Sp             -> ptext SLIT("Sp")
+        SpLim          -> ptext SLIT("SpLim")
+        Hp             -> ptext SLIT("Hp")
+        HpLim          -> ptext SLIT("HpLim")
+        CurrentTSO     -> ptext SLIT("CurrentTSO")
+        CurrentNursery -> ptext SLIT("CurrentNursery")
+        HpAlloc        -> ptext SLIT("HpAlloc")
+        GCEnter1       -> ptext SLIT("stg_gc_enter_1")
+        GCFun          -> ptext SLIT("stg_gc_fun")
+        BaseReg        -> ptext SLIT("BaseReg")
+        PicBaseReg     -> ptext SLIT("PicBaseReg")
+
+-- --------------------------------------------------------------------------
+-- data sections
+--
+pprSection :: Section -> SDoc
+pprSection s = case s of
+    Text              -> section <+> doubleQuotes (ptext SLIT("text"))
+    Data              -> section <+> doubleQuotes (ptext SLIT("data"))
+    ReadOnlyData      -> section <+> doubleQuotes (ptext SLIT("readonly"))
+    RelocatableReadOnlyData
+                      -> section <+> doubleQuotes (ptext SLIT("relreadonly"))
+    UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
+    OtherSection s'   -> section <+> doubleQuotes (text s')
+ where
+    section = ptext SLIT("section")
+       
+-- --------------------------------------------------------------------------
+-- Basic block ids
+--
+pprBlockId :: BlockId -> SDoc
+pprBlockId b = ppr $ getUnique b
+
+-----------------------------------------------------------------------------
+
+commafy :: [SDoc] -> SDoc
+commafy xs = hsep $ punctuate comma xs
+