Produce new-style Cmm from the Cmm parser
authorSimon Marlow <marlowsd@gmail.com>
Wed, 3 Oct 2012 08:30:56 +0000 (09:30 +0100)
committerSimon Marlow <marlowsd@gmail.com>
Mon, 8 Oct 2012 08:04:40 +0000 (09:04 +0100)
The main change here is that the Cmm parser now allows high-level cmm
code with argument-passing and function calls.  For example:

foo ( gcptr a, bits32 b )
{
  if (b > 0) {
     // we can make tail calls passing arguments:
     jump stg_ap_0_fast(a);
  }

  return (x,y);
}

More details on the new cmm syntax are in Note [Syntax of .cmm files]
in CmmParse.y.

The old syntax is still more-or-less supported for those occasional
code fragments that really need to explicitly manipulate the stack.
However there are a couple of differences: it is now obligatory to
give a list of live GlobalRegs on every jump, e.g.

  jump %ENTRY_CODE(Sp(0)) [R1];

Again, more details in Note [Syntax of .cmm files].

I have rewritten most of the .cmm files in the RTS into the new
syntax, except for AutoApply.cmm which is generated by the genapply
program: this file could be generated in the new syntax instead and
would probably be better off for it, but I ran out of enthusiasm.

Some other changes in this batch:

 - The PrimOp calling convention is gone, primops now use the ordinary
   NativeNodeCall convention.  This means that primops and "foreign
   import prim" code must be written in high-level cmm, but they can
   now take more than 10 arguments.

 - CmmSink now does constant-folding (should fix #7219)

 - .cmm files now go through the cmmPipeline, and as a result we
   generate better code in many cases.  All the object files generated
   for the RTS .cmm files are now smaller.  Performance should be
   better too, but I haven't measured it yet.

 - RET_DYN frames are removed from the RTS, lots of code goes away

 - we now have some more canned GC points to cover unboxed-tuples with
   2-4 pointers, which will reduce code size a little.

85 files changed:
compiler/cmm/CLabel.hs
compiler/cmm/Cmm.hs
compiler/cmm/CmmBuildInfoTables.hs
compiler/cmm/CmmCallConv.hs
compiler/cmm/CmmContFlowOpt.hs
compiler/cmm/CmmCvt.hs
compiler/cmm/CmmInfo.hs
compiler/cmm/CmmLayoutStack.hs
compiler/cmm/CmmLex.x
compiler/cmm/CmmMachOp.hs
compiler/cmm/CmmNode.hs
compiler/cmm/CmmOpt.hs
compiler/cmm/CmmParse.y
compiler/cmm/CmmPipeline.hs
compiler/cmm/CmmProcPoint.hs
compiler/cmm/CmmSink.hs
compiler/cmm/CmmType.hs
compiler/cmm/CmmUtils.hs
compiler/cmm/MkGraph.hs
compiler/cmm/OldCmm.hs
compiler/cmm/OldPprCmm.hs
compiler/cmm/PprC.hs
compiler/cmm/PprCmm.hs
compiler/cmm/SMRep.lhs
compiler/codeGen/CgCallConv.hs
compiler/codeGen/CgCon.lhs
compiler/codeGen/CgHeapery.lhs
compiler/codeGen/CgProf.hs
compiler/codeGen/CgUtils.hs
compiler/codeGen/ClosureInfo.lhs
compiler/codeGen/StgCmm.hs
compiler/codeGen/StgCmmBind.hs
compiler/codeGen/StgCmmClosure.hs
compiler/codeGen/StgCmmCon.hs
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmExtCode.hs [moved from compiler/codeGen/CgExtCode.hs with 66% similarity]
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmGran.hs
compiler/codeGen/StgCmmHeap.hs
compiler/codeGen/StgCmmHpc.hs
compiler/codeGen/StgCmmLayout.hs
compiler/codeGen/StgCmmMonad.hs
compiler/codeGen/StgCmmPrim.hs
compiler/codeGen/StgCmmProf.hs
compiler/codeGen/StgCmmTicky.hs
compiler/codeGen/StgCmmUtils.hs
compiler/ghc.cabal.in
compiler/llvmGen/LlvmCodeGen/CodeGen.hs
compiler/main/HscMain.hs
compiler/nativeGen/AsmCodeGen.lhs
compiler/nativeGen/RegAlloc/Linear/Main.hs
compiler/prelude/ForeignCall.lhs
compiler/typecheck/TcForeign.lhs
includes/Cmm.h
includes/Rts.h
includes/rts/Constants.h
includes/rts/storage/ClosureMacros.h
includes/rts/storage/ClosureTypes.h
includes/rts/storage/Closures.h
includes/rts/storage/Liveness.h [deleted file]
includes/rts/storage/SMPClosureOps.h
includes/stg/MiscClosures.h
includes/stg/Regs.h
rts/Apply.cmm
rts/AutoApply.h
rts/ClosureFlags.c
rts/Exception.cmm
rts/HeapStackCheck.cmm
rts/Interpreter.c
rts/LdvProfile.c
rts/Linker.c
rts/PrimOps.cmm
rts/Printer.c
rts/RaiseAsync.c
rts/RetainerProfile.c
rts/StgMiscClosures.cmm
rts/StgStartup.cmm
rts/StgStdThunks.cmm
rts/Updates.cmm
rts/Updates.h
rts/sm/Compact.c
rts/sm/Evac.c
rts/sm/Sanity.c
rts/sm/Scav.c
utils/genapply/GenApply.hs

index a5d559e..0431232 100644 (file)
@@ -72,7 +72,7 @@ module CLabel (
         mkCmmRetLabel,
         mkCmmCodeLabel,
         mkCmmDataLabel,
-        mkCmmGcPtrLabel,
+        mkCmmClosureLabel,
 
         mkRtsApFastLabel,
 
@@ -331,7 +331,7 @@ data CmmLabelInfo
   | CmmRet                      -- ^ misc rts return points,    suffix _ret
   | CmmData                     -- ^ misc rts data bits, eg CHARLIKE_closure
   | CmmCode                     -- ^ misc rts code
-  | CmmGcPtr                    -- ^ GcPtrs eg CHARLIKE_closure
+  | CmmClosure                  -- ^ closures eg CHARLIKE_closure
   | CmmPrimCall                 -- ^ a prim call to some hand written Cmm code
   deriving (Eq, Ord)
 
@@ -418,7 +418,7 @@ mkCAFBlackHoleEntryLabel        = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOL
 
 -----
 mkCmmInfoLabel,   mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
-  mkCmmCodeLabel, mkCmmDataLabel,  mkCmmGcPtrLabel
+  mkCmmCodeLabel, mkCmmDataLabel,  mkCmmClosureLabel
         :: PackageId -> FastString -> CLabel
 
 mkCmmInfoLabel      pkg str     = CmmLabel pkg str CmmInfo
@@ -427,7 +427,7 @@ mkCmmRetInfoLabel   pkg str     = CmmLabel pkg str CmmRetInfo
 mkCmmRetLabel       pkg str     = CmmLabel pkg str CmmRet
 mkCmmCodeLabel      pkg str     = CmmLabel pkg str CmmCode
 mkCmmDataLabel      pkg str     = CmmLabel pkg str CmmData
-mkCmmGcPtrLabel     pkg str     = CmmLabel pkg str CmmGcPtr
+mkCmmClosureLabel   pkg str     = CmmLabel pkg str CmmClosure
 
 
 -- Constructing RtsLabels
@@ -543,6 +543,7 @@ mkPlainModuleInitLabel mod      = PlainModuleInitLabel mod
 
 toClosureLbl :: CLabel -> CLabel
 toClosureLbl (IdLabel n c _) = IdLabel n c Closure
+toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure
 toClosureLbl l = pprPanic "toClosureLbl" (ppr l)
 
 toSlowEntryLbl :: CLabel -> CLabel
@@ -774,7 +775,7 @@ isGcPtrLabel lbl = case labelType lbl of
 --    whether it be code, data, or static GC object.
 labelType :: CLabel -> CLabelType
 labelType (CmmLabel _ _ CmmData)                = DataLabel
-labelType (CmmLabel _ _ CmmGcPtr)               = GcPtrLabel
+labelType (CmmLabel _ _ CmmClosure)             = GcPtrLabel
 labelType (CmmLabel _ _ CmmCode)                = CodeLabel
 labelType (CmmLabel _ _ CmmInfo)                = DataLabel
 labelType (CmmLabel _ _ CmmEntry)               = CodeLabel
@@ -1001,7 +1002,6 @@ pprCLbl (LargeBitmapLabel u)  = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLi
 
 pprCLbl (CmmLabel _ str CmmCode)        = ftext str
 pprCLbl (CmmLabel _ str CmmData)        = ftext str
-pprCLbl (CmmLabel _ str CmmGcPtr)       = ftext str
 pprCLbl (CmmLabel _ str CmmPrimCall)    = ftext str
 
 pprCLbl (RtsLabel (RtsApFast str))   = ftext str <> ptext (sLit "_fast")
@@ -1046,6 +1046,9 @@ pprCLbl (CmmLabel _ fs CmmRetInfo)
 pprCLbl (CmmLabel _ fs CmmRet)
   = ftext fs <> ptext (sLit "_ret")
 
+pprCLbl (CmmLabel _ fs CmmClosure)
+  = ftext fs <> ptext (sLit "_closure")
+
 pprCLbl (RtsLabel (RtsPrimOp primop))
   = ptext (sLit "stg_") <> ppr primop
 
index 2dedee0..8409f0d 100644 (file)
@@ -109,9 +109,14 @@ data CmmStackInfo
                -- number of bytes of arguments on the stack on entry to the
                -- the proc.  This is filled in by StgCmm.codeGen, and used
                -- by the stack allocator later.
-       updfr_space :: Maybe ByteOff
+       updfr_space :: Maybe ByteOff,
                -- XXX: this never contains anything useful, but it should.
                -- See comment in CmmLayoutStack.
+       do_layout :: Bool
+               -- Do automatic stack layout for this proc.  This is
+               -- True for all code generated by the code generator,
+               -- but is occasionally False for hand-written Cmm where
+               -- we want to do the stack manipulation manually.
   }
 
 -- | Info table as a haskell data type
index ecaab57..304f4c2 100644 (file)
@@ -235,8 +235,8 @@ to_SRT dflags top_srt off len bmp
            tbl = CmmData RelocatableReadOnlyData $
                    Statics srt_desc_lbl $ map CmmStaticLit
                      ( cmmLabelOffW dflags top_srt off
-                     : mkWordCLit dflags (toStgWord dflags (fromIntegral len))
-                     : map (mkWordCLit dflags) bmp)
+                     : mkWordCLit dflags (fromIntegral len)
+                     : map (mkStgWordCLit dflags) bmp)
        return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags))
   | otherwise
   = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp))))
@@ -252,7 +252,8 @@ localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
 localCAFInfo _      (CmmData _ _) = (Set.empty, Nothing)
 localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) =
   case topInfoTable proc of
-    Just (CmmInfoTable { cit_rep = rep }) | not (isStaticRep rep)
+    Just (CmmInfoTable { cit_rep = rep })
+      | not (isStaticRep rep) && not (isStackRep rep)
       -> (cafs, Just (toClosureLbl top_l))
     _other -> (cafs, Nothing)
   where
index 235fe7f..180b2d7 100644 (file)
@@ -8,7 +8,8 @@
 module CmmCallConv (
   ParamLocation(..),
   assignArgumentsPos,
-  globalArgRegs
+  assignStack,
+  globalArgRegs, realArgRegs
 ) where
 
 #include "HsVersions.h"
@@ -18,7 +19,6 @@ import SMRep
 import Cmm (Convention(..))
 import PprCmm ()
 
-import qualified Data.List as L
 import DynFlags
 import Outputable
 
@@ -33,15 +33,22 @@ instance Outputable ParamLocation where
   ppr (RegisterParam g) = ppr g
   ppr (StackParam p)    = ppr p
 
--- | JD: For the new stack story, I want arguments passed on the stack to manifest as
--- positive offsets in a CallArea, not negative offsets from the stack pointer.
--- Also, I want byte offsets, not word offsets.
-assignArgumentsPos :: DynFlags -> Convention -> (a -> CmmType) -> [a] ->
-                      [(a, ParamLocation)]
+-- |
 -- Given a list of arguments, and a function that tells their types,
 -- return a list showing where each argument is passed
-assignArgumentsPos dflags conv arg_ty reps = assignments
-    where -- The calling conventions (CgCallConv.hs) are complicated, to say the least
+--
+assignArgumentsPos :: DynFlags
+                   -> ByteOff           -- stack offset to start with
+                   -> Convention
+                   -> (a -> CmmType)    -- how to get a type from an arg
+                   -> [a]               -- args
+                   -> (
+                        ByteOff              -- bytes of stack args
+                      , [(a, ParamLocation)] -- args and locations
+                      )
+
+assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
+    where
       regs = case (reps, conv) of
                (_,   NativeNodeCall)   -> getRegsWithNode dflags
                (_,   NativeDirectCall) -> getRegsWithoutNode dflags
@@ -49,23 +56,14 @@ assignArgumentsPos dflags conv arg_ty reps = assignments
                (_,   NativeReturn)     -> getRegsWithNode dflags
                -- GC calling convention *must* put values in registers
                (_,   GC)               -> allRegs dflags
-               (_,   PrimOpCall)       -> allRegs dflags
-               ([_], PrimOpReturn)     -> allRegs dflags
-               (_,   PrimOpReturn)     -> getRegsWithNode dflags
                (_,   Slow)             -> noRegs
       -- The calling conventions first assign arguments to registers,
       -- then switch to the stack when we first run out of registers
-      -- (even if there are still available registers for args of a different type).
-      -- When returning an unboxed tuple, we also separate the stack
-      -- arguments by pointerhood.
-      (reg_assts, stk_args) = assign_regs [] reps regs
-      stk_args' = case conv of NativeReturn -> part
-                               PrimOpReturn -> part
-                               GC | length stk_args /= 0 -> panic "Failed to allocate registers for GC call"
-                               _            -> stk_args
-                  where part = uncurry (++)
-                                       (L.partition (not . isGcPtrType . arg_ty) stk_args)
-      stk_assts = assign_stk 0 [] (reverse stk_args')
+      -- (even if there are still available registers for args of a
+      -- different type).  When returning an unboxed tuple, we also
+      -- separate the stack arguments by pointerhood.
+      (reg_assts, stk_args)  = assign_regs [] reps regs
+      (stk_off,   stk_assts) = assignStack dflags off arg_ty stk_args
       assignments = reg_assts ++ stk_assts
 
       assign_regs assts []     _    = (assts, [])
@@ -88,11 +86,21 @@ assignArgumentsPos dflags conv arg_ty reps = assignments
               gcp | isGcPtrType ty = VGcPtr
                   | otherwise             = VNonGcPtr
 
-      assign_stk _      assts [] = assts
-      assign_stk offset assts (r:rs) = assign_stk off' ((r, StackParam off') : assts) rs
+
+assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]
+            -> (
+                 ByteOff              -- bytes of stack args
+               , [(a, ParamLocation)] -- args and locations
+               )
+assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
+ where
+      assign_stk offset assts [] = (offset, assts)
+      assign_stk offset assts (r:rs)
+        = assign_stk off' ((r, StackParam off') : assts) rs
         where w    = typeWidth (arg_ty r)
-              size = (((widthInBytes w - 1) `div` wORD_SIZE dflags) + 1) * wORD_SIZE dflags
+              size = (((widthInBytes w - 1) `div` word_size) + 1) * word_size
               off' = offset + size
+              word_size = wORD_SIZE dflags
 
 -----------------------------------------------------------------------------
 -- Local information about the registers available
@@ -158,3 +166,9 @@ globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++
                        allFloatRegs dflags ++
                        allDoubleRegs dflags ++
                        allLongRegs dflags
+
+realArgRegs :: DynFlags -> [GlobalReg]
+realArgRegs dflags = map ($VGcPtr) (realVanillaRegs dflags) ++
+                realFloatRegs dflags ++
+                realDoubleRegs dflags ++
+                realLongRegs dflags
index aa2925f..4028efd 100644 (file)
@@ -97,15 +97,17 @@ cmmCfgOptsProc _ top = top
 
 blockConcat :: Bool -> CmmGraph -> (CmmGraph, BlockEnv BlockId)
 blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
-  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map)
+  = (replaceLabels shortcut_map $ ofBlockMap new_entry new_blocks, shortcut_map')
   where
-     -- we might be able to shortcut the entry BlockId itself
-     new_entry
+     -- we might be able to shortcut the entry BlockId itself.
+     -- remember to update the shortcut_map', since we also have to
+     -- update the info_tbls mapping now.
+     (new_entry, shortcut_map')
        | Just entry_blk <- mapLookup entry_id new_blocks
        , Just dest      <- canShortcut entry_blk
-       = dest
+       = (dest, mapInsert entry_id dest shortcut_map)
        | otherwise
-       = entry_id
+       = (entry_id, shortcut_map)
 
      blocks = postorderDfs g
      blockmap = foldr addBlock emptyBody blocks
index cd83882..017d120 100644 (file)
@@ -22,19 +22,23 @@ cmmOfZgraph tops = map mapTop tops
   where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g)
         mapTop (CmmData s ds) = CmmData s ds
 
-data ValueDirection = Arguments | Results
+add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a]
+add_hints args hints = zipWith Old.CmmHinted args hints
 
-add_hints :: ForeignTarget -> ValueDirection -> [a] -> [Old.CmmHinted a]
-add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd)
-
-get_hints :: ForeignTarget -> ValueDirection -> [ForeignHint]
-get_hints (ForeignTarget _ (ForeignConvention _ hints _)) Arguments = hints
-get_hints (ForeignTarget _ (ForeignConvention _ _ hints)) Results   = hints
-get_hints (PrimTarget _) _vd = repeat NoHint
+get_hints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
+get_hints (PrimTarget op) = (res_hints ++ repeat NoHint,
+                             arg_hints ++ repeat NoHint)
+  where (res_hints, arg_hints) = callishMachOpHints op
+get_hints (ForeignTarget _ (ForeignConvention _ arg_hints res_hints _))
+  = (res_hints, arg_hints)
 
 cmm_target :: ForeignTarget -> Old.CmmCallTarget
 cmm_target (PrimTarget op) = Old.CmmPrim op Nothing
-cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc
+cmm_target (ForeignTarget e (ForeignConvention cc _ _ _)) = Old.CmmCallee e cc
+
+get_ret :: ForeignTarget -> CmmReturnInfo
+get_ret (PrimTarget _) = CmmMayReturn
+get_ret (ForeignTarget _ (ForeignConvention _ _ _ ret)) = ret
 
 ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
 ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
@@ -83,11 +87,14 @@ ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
                             CmmAssign l r                                  -> Old.CmmAssign l r
                             CmmStore  l r                                  -> Old.CmmStore  l r
                             CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
-                            CmmUnsafeForeignCall target ress args          -> 
+                            CmmUnsafeForeignCall target ress args          ->
                               Old.CmmCall (cmm_target target)
-                                          (add_hints target Results   ress)
-                                          (add_hints target Arguments args)
-                                          Old.CmmMayReturn
+                                          (add_hints ress res_hints)
+                                          (add_hints args arg_hints)
+                                          (get_ret target)
+                                  where
+                                     (res_hints, arg_hints) = get_hints target
+
 
                   last :: CmmNode O C -> () -> [Old.CmmStmt]
                   last node _ = stmts
index 6aa4d6c..dec6b5d 100644 (file)
@@ -155,7 +155,7 @@ type InfoTableContents = ( [CmmLit]      -- The standard part
 
 mkInfoTableContents :: DynFlags
                     -> CmmInfoTable
-                    -> Maybe StgHalfWord    -- Override default RTS type tag?
+                    -> Maybe Int               -- Override default RTS type tag?
                     -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls
                                InfoTableContents)      -- Info tbl + extra bits
 
@@ -178,22 +178,19 @@ mkInfoTableContents dflags
        ; let
              std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
              rts_tag | Just tag <- mb_rts_tag = tag
-                     | null liveness_data     = rET_SMALL dflags -- Fits in extra_bits
-                     | otherwise              = rET_BIG   dflags -- Does not; extra_bits is
-                                                                 -- a label
+                     | null liveness_data     = rET_SMALL -- Fits in extra_bits
+                     | otherwise              = rET_BIG   -- Does not; extra_bits is
+                                                          -- a label
        ; return (prof_data ++ liveness_data, (std_info, srt_label)) }
 
   | HeapRep _ ptrs nonptrs closure_type <- smrep
-  = do { let layout  = packHalfWordsCLit
-                           dflags
-                           (toStgHalfWord dflags (toInteger ptrs))
-                           (toStgHalfWord dflags (toInteger nonptrs))
+  = do { let layout  = packIntsCLit dflags ptrs nonptrs
        ; (prof_lits, prof_data) <- mkProfLits dflags prof
        ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
        ; (mb_srt_field, mb_layout, extra_bits, ct_data)
                                 <- mk_pieces closure_type srt_label
        ; let std_info = mkStdInfoTable dflags prof_lits
-                                       (mb_rts_tag   `orElse` rtsClosureType dflags smrep)
+                                       (mb_rts_tag   `orElse` rtsClosureType smrep)
                                        (mb_srt_field `orElse` srt_bitmap)
                                        (mb_layout    `orElse` layout)
        ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
@@ -205,24 +202,25 @@ mkInfoTableContents dflags
                        , [RawCmmDecl])      -- Auxiliary data decls 
     mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor
       = do { (descr_lit, decl) <- newStringLit con_descr
-          ; return (Just con_tag, Nothing, [descr_lit], [decl]) }
+           ; return ( Just (toStgHalfWord dflags (fromIntegral con_tag))
+                    , Nothing, [descr_lit], [decl]) }
 
     mk_pieces Thunk srt_label
       = return (Nothing, Nothing, srt_label, [])
 
     mk_pieces (ThunkSelector offset) _no_srt
-      = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags offset), [], [])
+      = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags (fromIntegral offset)), [], [])
          -- Layout known (one free var); we use the layout field for offset
 
     mk_pieces (Fun arity (ArgSpec fun_type)) srt_label 
-      = do { let extra_bits = packHalfWordsCLit dflags fun_type arity : srt_label
+      = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label
            ; return (Nothing, Nothing,  extra_bits, []) }
 
     mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
       = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
-           ; let fun_type | null liveness_data = aRG_GEN     dflags
-                          | otherwise          = aRG_GEN_BIG dflags
-                 extra_bits = [ packHalfWordsCLit dflags fun_type arity
+           ; let fun_type | null liveness_data = aRG_GEN
+                          | otherwise          = aRG_GEN_BIG
+                 extra_bits = [ packIntsCLit dflags fun_type arity
                               , srt_lit, liveness_lit, slow_entry ]
            ; return (Nothing, Nothing, extra_bits, liveness_data) }
       where
@@ -233,9 +231,14 @@ mkInfoTableContents dflags
 
     mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"
 
-
 mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
 
+packIntsCLit :: DynFlags -> Int -> Int -> CmmLit
+packIntsCLit dflags a b = packHalfWordsCLit dflags
+                           (toStgHalfWord dflags (fromIntegral a))
+                           (toStgHalfWord dflags (fromIntegral b))
+
+
 mkSRTLit :: DynFlags
          -> C_SRT
          -> ([CmmLit],    -- srt_label, if any
@@ -314,7 +317,7 @@ mkLivenessBits dflags liveness
                  [mkRODataLits bitmap_lbl lits]) }
 
   | otherwise -- Fits in one word
-  = return (mkWordCLit dflags bitmap_word, [])
+  = return (mkStgWordCLit dflags bitmap_word, [])
   where
     n_bits = length liveness
 
@@ -328,7 +331,8 @@ mkLivenessBits dflags liveness
     bitmap_word = toStgWord dflags (fromIntegral n_bits)
               .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
 
-    lits = mkWordCLit dflags (toStgWord dflags (fromIntegral n_bits)) : map (mkWordCLit dflags) bitmap
+    lits = mkWordCLit dflags (fromIntegral n_bits)
+         : map (mkStgWordCLit dflags) bitmap
       -- The first word is the size.  The structure must match
       -- StgLargeBitmap in includes/rts/storage/InfoTable.h
 
@@ -348,8 +352,8 @@ mkLivenessBits dflags liveness
 mkStdInfoTable
    :: DynFlags
    -> (CmmLit,CmmLit)  -- Closure type descr and closure descr  (profiling)
-   -> StgHalfWord      -- Closure RTS tag 
-   -> StgHalfWord      -- SRT length
+   -> Int               -- Closure RTS tag
+   -> StgHalfWord       -- SRT length
    -> CmmLit           -- layout field
    -> [CmmLit]
 
@@ -365,7 +369,7 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
        | dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
        | otherwise = []
 
-    type_lit = packHalfWordsCLit dflags cl_type srt_len
+    type_lit = packHalfWordsCLit dflags (toStgHalfWord dflags (fromIntegral cl_type)) srt_len
 
 -------------------------------------------------------------------------
 --
index 6f75f54..5c40457 100644 (file)
@@ -933,7 +933,7 @@ lowerSafeForeignCall dflags block
 
         (ret_args, regs, copyout) = copyOutOflow dflags NativeReturn Jump (Young succ)
                                            (map (CmmReg . CmmLocal) res)
-                                           updfr (0, [])
+                                           updfr []
 
         -- NB. after resumeThread returns, the top-of-stack probably contains
         -- the stack frame for succ, but it might not: if the current thread
@@ -973,14 +973,14 @@ callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
 callSuspendThread dflags id intrbl =
   CmmUnsafeForeignCall
        (ForeignTarget (foreignLbl (fsLit "suspendThread"))
-             (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
+        (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
        [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)]
 
 callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
 callResumeThread new_base id =
   CmmUnsafeForeignCall
        (ForeignTarget (foreignLbl (fsLit "resumeThread"))
-            (ForeignConvention CCallConv [AddrHint] [AddrHint]))
+            (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))
        [new_base] [CmmReg (CmmLocal id)]
 
 -- -----------------------------------------------------------------------------
index ddd681d..718eb27 100644 (file)
@@ -23,9 +23,9 @@ module CmmLex (
    CmmToken(..), cmmlex,
   ) where
 
-import OldCmm
-import Lexer
+import CmmExpr
 
+import Lexer
 import SrcLoc
 import UniqFM
 import StringBuffer
@@ -147,6 +147,7 @@ data CmmToken
   | CmmT_align
   | CmmT_goto
   | CmmT_if
+  | CmmT_call
   | CmmT_jump
   | CmmT_foreign
   | CmmT_never
@@ -157,6 +158,7 @@ data CmmToken
   | CmmT_switch
   | CmmT_case
   | CmmT_default
+  | CmmT_push
   | CmmT_bits8
   | CmmT_bits16
   | CmmT_bits32
@@ -224,8 +226,9 @@ reservedWordsFM = listToUFM $
        ( "align",              CmmT_align ),
        ( "goto",               CmmT_goto ),
        ( "if",                 CmmT_if ),
-       ( "jump",               CmmT_jump ),
-       ( "foreign",            CmmT_foreign ),
+        ( "call",               CmmT_call ),
+        ( "jump",               CmmT_jump ),
+        ( "foreign",            CmmT_foreign ),
        ( "never",              CmmT_never ),
        ( "prim",               CmmT_prim ),
        ( "return",             CmmT_return ),
@@ -233,8 +236,9 @@ reservedWordsFM = listToUFM $
        ( "import",             CmmT_import ),
        ( "switch",             CmmT_switch ),
        ( "case",               CmmT_case ),
-       ( "default",            CmmT_default ),
-       ( "bits8",              CmmT_bits8 ),
+        ( "default",            CmmT_default ),
+        ( "push",               CmmT_push ),
+        ( "bits8",              CmmT_bits8 ),
        ( "bits16",             CmmT_bits16 ),
        ( "bits32",             CmmT_bits32 ),
        ( "bits64",             CmmT_bits64 ),
index 520c7e7..c00cdb5 100644 (file)
@@ -16,7 +16,7 @@ module CmmMachOp
     , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32, mo_WordTo64
 
     -- CallishMachOp
-    , CallishMachOp(..)
+    , CallishMachOp(..), callishMachOpHints
     , pprCallishMachOp
    )
 where
@@ -463,3 +463,10 @@ data CallishMachOp
 pprCallishMachOp :: CallishMachOp -> SDoc
 pprCallishMachOp mo = text (show mo)
 
+callishMachOpHints :: CallishMachOp -> ([ForeignHint], [ForeignHint])
+callishMachOpHints op = case op of
+  MO_Memcpy  -> ([], [AddrHint,AddrHint,NoHint,NoHint])
+  MO_Memset  -> ([], [AddrHint,NoHint,NoHint,NoHint])
+  MO_Memmove -> ([], [AddrHint,AddrHint,NoHint,NoHint])
+  _          -> ([],[])
+  -- empty lists indicate NoHint
index ae7ac09..b7bb270 100644 (file)
@@ -9,8 +9,9 @@
 -- for details
 
 module CmmNode (
-     CmmNode(..), ForeignHint(..), CmmFormal, CmmActual,
+     CmmNode(..), CmmFormal, CmmActual,
      UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..),
+     CmmReturnInfo(..),
      mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
      mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors
   ) where
@@ -228,14 +229,31 @@ type CmmFormal = LocalReg
 
 type UpdFrameOffset = ByteOff
 
+-- | A convention maps a list of values (function arguments or return
+-- values) to registers or stack locations.
 data Convention
-  = NativeDirectCall -- Native C-- call skipping the node (closure) argument
-  | NativeNodeCall   -- Native C-- call including the node argument
-  | NativeReturn     -- Native C-- return
-  | Slow             -- Slow entry points: all args pushed on the stack
-  | GC               -- Entry to the garbage collector: uses the node reg!
-  | PrimOpCall       -- Calling prim ops
-  | PrimOpReturn     -- Returning from prim ops
+  = NativeDirectCall
+       -- ^ top-level Haskell functions use @NativeDirectCall@, which
+       -- maps arguments to registers starting with R2, according to
+       -- how many registers are available on the platform.  This
+       -- convention ignores R1, because for a top-level function call
+       -- the function closure is implicit, and doesn't need to be passed.
+  | NativeNodeCall
+       -- ^ non-top-level Haskell functions, which pass the address of
+       -- the function closure in R1 (regardless of whether R1 is a
+       -- real register or not), and the rest of the arguments in
+       -- registers or on the stack.
+  | NativeReturn
+       -- ^ a native return.  The convention for returns depends on
+       -- how many values are returned: for just one value returned,
+       -- the appropriate register is used (R1, F1, etc.). regardless
+       -- of whether it is a real register or not.  For multiple
+       -- values returned, they are mapped to registers or the stack.
+  | Slow
+       -- ^ Slow entry points: all args pushed on the stack
+  | GC
+       -- ^ Entry to the garbage collector: uses the node reg!
+       -- (TODO: I don't think we need this --SDM)
   deriving( Eq )
 
 data ForeignConvention
@@ -243,8 +261,14 @@ data ForeignConvention
         CCallConv               -- Which foreign-call convention
         [ForeignHint]           -- Extra info about the args
         [ForeignHint]           -- Extra info about the result
+        CmmReturnInfo
   deriving Eq
 
+data CmmReturnInfo
+  = CmmMayReturn
+  | CmmNeverReturns
+  deriving ( Eq )
+
 data ForeignTarget        -- The target of a foreign call
   = ForeignTarget                -- A foreign procedure
         CmmExpr                  -- Its address
@@ -253,12 +277,6 @@ data ForeignTarget        -- The target of a foreign call
         CallishMachOp            -- Which one
   deriving Eq
 
-data ForeignHint
-  = NoHint | AddrHint | SignedHint
-  deriving( Eq )
-        -- Used to give extra per-argument or per-result
-        -- information needed by foreign calling conventions
-
 --------------------------------------------------
 -- Instances of register and slot users / definers
 
index 32afa1d..8436263 100644 (file)
@@ -14,6 +14,7 @@ module CmmOpt (
 
 #include "HsVersions.h"
 
+import CmmUtils
 import OldCmm
 import DynFlags
 import CLabel
@@ -184,22 +185,22 @@ cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], ar
 
 -- Make a RegOff if we can
 cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]
-  = Just $ CmmRegOff reg (fromIntegral (narrowS rep n))
+  = Just $ cmmRegOff reg (fromIntegral (narrowS rep n))
 cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
-  = Just $ CmmRegOff reg (off + fromIntegral (narrowS rep n))
+  = Just $ cmmRegOff reg (off + fromIntegral (narrowS rep n))
 cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]
-  = Just $ CmmRegOff reg (- fromIntegral (narrowS rep n))
+  = Just $ cmmRegOff reg (- fromIntegral (narrowS rep n))
 cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]
-  = Just $ CmmRegOff reg (off - fromIntegral (narrowS rep n))
+  = Just $ cmmRegOff reg (off - fromIntegral (narrowS rep n))
 
 -- Fold label(+/-)offset into a CmmLit where possible
 
-cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
-  = Just $ CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
-cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)]
-  = Just $ CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i)))
-cmmMachOpFoldM _ (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)]
-  = Just $ CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i))))
+cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]
+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))
+cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]
+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i)))
+cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]
+  = Just $ CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))
 
 
 -- Comparison of literal with widened operand: perform the comparison
index 8c3559b..22e28a8 100644 (file)
 -----------------------------------------------------------------------------
 --
--- (c) The University of Glasgow, 2004-2006
+-- (c) The University of Glasgow, 2004-2012
 --
 -- Parser for concrete Cmm.
--- This doesn't just parse the Cmm file, we also do some code generation
--- along the way for switches and foreign calls etc.
 --
 -----------------------------------------------------------------------------
 
--- TODO: Add support for interruptible/uninterruptible foreign call specification
+{- -----------------------------------------------------------------------------
+Note [Syntax of .cmm files]
+
+NOTE: You are very much on your own in .cmm.  There is very little
+error checking at all:
+
+  * Type errors are detected by the (optional) -dcmm-lint pass, if you
+    don't turn this on then a type error will likely result in a panic
+    from the native code generator.
+
+  * Passing the wrong number of arguments or arguments of the wrong
+    type is not detected.
+
+There are two ways to write .cmm code:
+
+ (1) High-level Cmm code delegates the stack handling to GHC, and
+     never explicitly mentions Sp or registers.
+
+ (2) Low-level Cmm manages the stack itself, and must know about
+     calling conventions.
+
+Whether you want high-level or low-level Cmm is indicated by the
+presence of an argument list on a procedure.  For example:
+
+foo ( gcptr a, bits32 b )
+{
+  // this is high-level cmm code
+
+  if (b > 0) {
+     // we can make tail calls passing arguments:
+     jump stg_ap_0_fast(a);
+  }
+
+  push (stg_upd_frame_info, a) {
+    // stack frames can be explicitly pushed
+
+    (x,y) = call wibble(a,b,3,4);
+      // calls pass arguments and return results using the native
+      // Haskell calling convention.  The code generator will automatically
+      // construct a stack frame and an info table for the continuation.
+
+    return (x,y);
+      // we can return multiple values from the current proc
+  }
+}
+
+bar
+{
+  // this is low-level cmm code, indicated by the fact that we did not
+  // put an argument list on bar.
+
+  x = R1;  // the calling convention is explicit: better be careful
+           // that this works on all platforms!
+
+  jump %ENTRY_CODE(Sp(0))
+}
+
+Here is a list of rules for high-level and low-level code.  If you
+break the rules, you get a panic (for using a high-level construct in
+a low-level proc), or wrong code (when using low-level code in a
+high-level proc).  This stuff isn't checked! (TODO!)
+
+High-level only:
+
+  - tail-calls with arguments, e.g.
+    jump stg_fun (arg1, arg2);
+
+  - function calls:
+    (ret1,ret2) = call stg_fun (arg1, arg2);
+
+    This makes a call with the NativeNodeCall convention, and the
+    values are returned to the following code using the NativeReturn
+    convention.
+
+  - returning:
+    return (ret1, ret2)
+
+    These use the NativeReturn convention to return zero or more
+    results to the caller.
+
+  - pushing stack frames:
+    push (info_ptr, field1, ..., fieldN) { ... statements ... }
+
+Low-level only:
+
+  - References to Sp, R1-R8, F1-F4 etc.
+
+    NB. foreign calls may clobber the argument registers R1-R8, F1-F4
+    etc., so ensure they are saved into variables around foreign
+    calls.
+
+  - SAVE_THREAD_STATE() and LOAD_THREAD_STATE(), which modify Sp
+    directly.
+
+Both high-level and low-level code can use a raw tail-call:
+
+    jump stg_fun [R1,R2]
+
+This always transfers control to a low-level Cmm function, but the
+call can be made from high-level code.  Arguments must be passed
+explicitly in R/F/D/L registers.
+
+NB. you *must* specify the list of GlobalRegs that are passed via a
+jump, otherwise the register allocator will assume that all the
+GlobalRegs are dead at the jump.
+
+
+A stack frame is written like this:
+
+INFO_TABLE_RET ( label, FRAME_TYPE, info_ptr, field1, ..., fieldN )
+               return ( arg1, ..., argM )
+{
+  ... code ...
+}
+
+where field1 ... fieldN are the fields of the stack frame (with types)
+arg1...argN are the values returned to the stack frame (with types).
+The return values are assumed to be passed according to the
+NativeReturn convention.
+
+On entry to the code, the stack frame looks like:
+
+   |----------|
+   | fieldN   |
+   |   ...    |
+   | field1   |
+   |----------|
+   | info_ptr |
+   |----------|
+   |  argN    |
+   |   ...    | <- Sp
+
+and some of the args may be in registers.
+
+We prepend the code by a copyIn of the args, and assign all the stack
+frame fields to their formals.  The initial "arg offset" for stack
+layout purposes consists of the whole stack frame plus any args that
+might be on the stack.
+
+A tail-call may pass a stack frame to the callee using the following
+syntax:
+
+jump f (info_ptr, field1,..,fieldN) (arg1,..,argN)
+
+where info_ptr and field1..fieldN describe the stack frame, and
+arg1..argN are the arguments passed to f using the NativeNodeCall
+convention.
+
+----------------------------------------------------------------------------- -}
 
 {
 {-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6
 
 module CmmParse ( parseCmmFile ) where
 
-import CgMonad
-import CgExtCode
-import CgHeapery
-import CgUtils
-import CgProf
-import CgTicky
-import CgInfoTbls
-import CgForeignCall
-import CgTailCall
-import CgStackery
-import ClosureInfo
-import CgCallConv
-import CgClosure
-import CostCentre
-
-import BlockId
-import OldCmm
-import OldPprCmm()
+import StgCmmExtCode
+import CmmCallConv
+import StgCmmProf
+import StgCmmHeap
+import StgCmmMonad hiding ( getCode, getCodeR, emitLabel, emit, emitStore
+                          , emitAssign, emitOutOfLine, withUpdFrameOff
+                          , getUpdFrameOff )
+import qualified StgCmmMonad as F
+import StgCmmUtils
+import StgCmmForeign
+import StgCmmExpr
+import StgCmmClosure
+import StgCmmLayout
+import StgCmmTicky
+import StgCmmBind       ( emitBlackHoleCode, emitUpdateFrame )
+
+import MkGraph
+import Cmm
 import CmmUtils
+import BlockId
 import CmmLex
 import CLabel
 import SMRep
 import Lexer
 
+import CostCentre
 import ForeignCall
 import Module
 import Platform
@@ -68,6 +216,7 @@ import Control.Monad
 import Data.Array
 import Data.Char        ( ord )
 import System.Exit
+import Data.Maybe
 
 #include "HsVersions.h"
 }
@@ -110,41 +259,43 @@ import System.Exit
         '&&'    { 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) }
-        'never'                 { L _ (CmmT_never) }
-        'prim'                  { L _ (CmmT_prim) }
-        'return'                { L _ (CmmT_return) }
-        'returns'               { L _ (CmmT_returns) }
-        '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) }
-        'gcptr'                 { L _ (CmmT_gcptr) }
-
-        GLOBALREG               { L _ (CmmT_GlobalReg   $$) }
-        NAME                    { L _ (CmmT_Name        $$) }
-        STRING                  { L _ (CmmT_String      $$) }
-        INT                     { L _ (CmmT_Int         $$) }
-        FLOAT                   { L _ (CmmT_Float       $$) }
+        '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) }
+        'call'          { L _ (CmmT_call) }
+        'jump'          { L _ (CmmT_jump) }
+        'foreign'       { L _ (CmmT_foreign) }
+       'never'         { L _ (CmmT_never) }
+       'prim'          { L _ (CmmT_prim) }
+       'return'        { L _ (CmmT_return) }
+       'returns'       { L _ (CmmT_returns) }
+       'import'        { L _ (CmmT_import) }
+       'switch'        { L _ (CmmT_switch) }
+       'case'          { L _ (CmmT_case) }
+        'default'       { L _ (CmmT_default) }
+        'push'          { L _ (CmmT_push) }
+        'bits8'         { L _ (CmmT_bits8) }
+       'bits16'        { L _ (CmmT_bits16) }
+       'bits32'        { L _ (CmmT_bits32) }
+       'bits64'        { L _ (CmmT_bits64) }
+       'float32'       { L _ (CmmT_float32) }
+       'float64'       { L _ (CmmT_float64) }
+       'gcptr'         { L _ (CmmT_gcptr) }
+
+       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 }
@@ -166,18 +317,18 @@ import System.Exit
 
 %%
 
-cmm     :: { ExtCode }
-        : {- empty -}                   { return () }
-        | cmmtop cmm                    { do $1; $2 }
+cmm     :: { CmmParse () }
+       : {- empty -}                   { return () }
+       | cmmtop cmm                    { do $1; $2 }
 
-cmmtop  :: { ExtCode }
-        : cmmproc                       { $1 }
-        | cmmdata                       { $1 }
-        | decl                          { $1 }
-        | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
-                {% withThisPackage $ \pkg ->
-                   do lits <- sequence $6;
-                      staticClosure pkg $3 $5 (map getLit lits) }
+cmmtop  :: { CmmParse () }
+       : cmmproc                       { $1 }
+       | cmmdata                       { $1 }
+       | decl                          { $1 } 
+       | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'  
+               {% withThisPackage $ \pkg -> 
+                  do lits <- sequence $6;
+                     staticClosure pkg $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
@@ -188,37 +339,37 @@ cmmtop  :: { ExtCode }
 --      * payload is always empty
 --      * we can derive closure and info table labels from a single NAME
 
-cmmdata :: { ExtCode }
-        : 'section' STRING '{' data_label statics '}'
-                { do lbl <- $4;
-                     ss <- sequence $5;
-                     code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) }
-
-data_label :: { ExtFCode CLabel }
-    : NAME ':'
-                {% withThisPackage $ \pkg ->
-                   return (mkCmmDataLabel pkg $1) }
-
-statics :: { [ExtFCode [CmmStatic]] }
-        : {- empty -}                   { [] }
-        | static statics                { $1 : $2 }
-
+cmmdata :: { CmmParse () }
+       : 'section' STRING '{' data_label statics '}' 
+               { do lbl <- $4;
+                    ss <- sequence $5;
+                    code (emitDecl (CmmData (section $2) (Statics lbl $ concat ss))) }
+
+data_label :: { CmmParse CLabel }
+    : NAME ':' 
+               {% withThisPackage $ \pkg -> 
+                  return (mkCmmDataLabel pkg $1) }
+
+statics        :: { [CmmParse [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] }
-        : type expr ';' { do e <- $2;
-                             return [CmmStaticLit (getLit e)] }
-        | type ';'                      { return [CmmUninitialised
-                                                        (widthInBytes (typeWidth $1))] }
-        | 'bits8' '[' ']' STRING ';'    { return [mkString $4] }
-        | 'bits8' '[' INT ']' ';'       { return [CmmUninitialised
-                                                        (fromIntegral $3)] }
-        | typenot8 '[' INT ']' ';'      { return [CmmUninitialised
-                                                (widthInBytes (typeWidth $1) *
-                                                        fromIntegral $3)] }
-        | 'CLOSURE' '(' NAME lits ')'
-                { do { lits <- sequence $4
-             ; dflags <- getDynFlags
+static  :: { CmmParse [CmmStatic] }
+       : type expr ';' { do e <- $2;
+                            return [CmmStaticLit (getLit e)] }
+       | type ';'                      { return [CmmUninitialised
+                                                       (widthInBytes (typeWidth $1))] }
+        | 'bits8' '[' ']' STRING ';'   { return [mkString $4] }
+        | 'bits8' '[' INT ']' ';'      { return [CmmUninitialised 
+                                                       (fromIntegral $3)] }
+        | typenot8 '[' INT ']' ';'     { return [CmmUninitialised 
+                                               (widthInBytes (typeWidth $1) * 
+                                                       fromIntegral $3)] }
+       | 'CLOSURE' '(' NAME lits ')'
+               { do { lits <- sequence $4
+                ; dflags <- getDynFlags
                      ; return $ map CmmStaticLit $
                         mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
                          -- mkForeignLabel because these are only used
@@ -226,140 +377,140 @@ static  :: { ExtFCode [CmmStatic] }
                         dontCareCCS (map getLit lits) [] [] [] } }
         -- arrays of closures required for the CHARLIKE & INTLIKE arrays
 
-lits    :: { [ExtFCode CmmExpr] }
-        : {- empty -}           { [] }
-        | ',' expr lits         { $2 : $3 }
-
-cmmproc :: { ExtCode }
--- TODO: add real SRT/info tables to parsed Cmm
-        : info maybe_formals_without_hints '{' body '}'
-                { do ((entry_ret_label, info, live, formals), stmts) <-
-                       getCgStmtsEC' $ loopDecls $ do {
-                         (entry_ret_label, info, live) <- $1;
-                         formals <- sequence $2;
+lits    :: { [CmmParse CmmExpr] }
+       : {- empty -}           { [] }
+       | ',' expr lits         { $2 : $3 }
+
+cmmproc :: { CmmParse () }
+        : info maybe_conv maybe_formals maybe_body
+                { do ((entry_ret_label, info, stk_formals, formals), agraph) <-
+                       getCodeR $ loopDecls $ do {
+                         (entry_ret_label, info, stk_formals) <- $1;
+                         formals <- sequence (fromMaybe [] $3);
                          $4;
-                         return (entry_ret_label, info, live, formals) }
-                     blks <- code (cgStmtsToBlocks stmts)
-                     code (emitInfoTableAndCode entry_ret_label info formals blks) }
+                         return (entry_ret_label, info, stk_formals, formals) }
+                     let do_layout = isJust $3
+                     code (emitProcWithStackFrame $2 info
+                                entry_ret_label stk_formals formals agraph
+                                do_layout ) }
 
-        | info maybe_formals_without_hints ';'
-                { do (entry_ret_label, info, live) <- $1;
-                     formals <- sequence $2;
-                     code (emitInfoTableAndCode entry_ret_label info formals []) }
+maybe_conv :: { Convention }
+           : {- empty -}        { NativeNodeCall }
+           | 'return'           { NativeReturn }
 
-        | NAME maybe_formals_without_hints '{' body '}'
-                {% withThisPackage $ \pkg ->
-                   do   newFunctionName $1 pkg
-                        (formals, stmts) <-
-                                getCgStmtsEC' $ loopDecls $ do {
-                                        formals <- sequence $2;
-                                        $4;
-                                        return formals }
-                        blks <- code (cgStmtsToBlocks stmts)
-                        code (emitProc Nothing (mkCmmCodeLabel pkg $1) formals blks) }
-
-info    :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-        : 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' STRING ',' STRING ')'
-                -- ptrs, nptrs, closure type, description, type
-                {% withThisPackage $ \pkg ->
+maybe_body :: { CmmParse () }
+           : ';'                { return () }
+           | '{' body '}'       { $2 }
+
+info    :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
+        : NAME
+               {% withThisPackage $ \pkg ->
+                  do   newFunctionName $1 pkg
+                        return (mkCmmCodeLabel pkg $1, Nothing, []) }
+
+
+        | 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
+               -- ptrs, nptrs, closure type, description, type
+               {% withThisPackage $ \pkg ->
                    do dflags <- getDynFlags
                       let prof = profilingInfo dflags $11 $13
-                          rep  = mkRTSRep $9 $
+                          rep  = mkRTSRep (fromIntegral $9) $
                                    mkHeapRep dflags False (fromIntegral $5)
                                                    (fromIntegral $7) Thunk
                               -- not really Thunk, but that makes the info table
                               -- we want.
                       return (mkCmmEntryLabel pkg $3,
-                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
-                                           , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
-                              []) }
-
-        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' STRING ',' STRING ',' stgHalfWord ')'
-                -- ptrs, nptrs, closure type, description, type, fun type
-                {% withThisPackage $ \pkg ->
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                          , cit_rep = rep
+                                                  , cit_prof = prof, cit_srt = NoC_SRT },
+                             []) }
+       
+        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
+               -- ptrs, nptrs, closure type, description, type, fun type
+               {% withThisPackage $ \pkg -> 
                    do dflags <- getDynFlags
                       let prof = profilingInfo dflags $11 $13
-                          ty   = Fun (toStgHalfWord dflags 0) (ArgSpec $15)
+                          ty   = Fun 0 (ArgSpec (fromIntegral $15))
                                 -- Arity zero, arg_type $15
-                          rep = mkRTSRep $9 $
+                          rep = mkRTSRep (fromIntegral $9) $
                                     mkHeapRep dflags False (fromIntegral $5)
                                                     (fromIntegral $7) ty
                       return (mkCmmEntryLabel pkg $3,
-                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
-                                           , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
-                              []) }
-                -- we leave most of the fields zero here.  This is only used
-                -- to generate the BCO info table in the RTS at the moment.
-
-        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' stgHalfWord ',' stgHalfWord ',' STRING ',' STRING ')'
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                          , cit_rep = rep
+                                                  , cit_prof = prof, cit_srt = NoC_SRT },
+                             []) }
+               -- we leave most of the fields zero here.  This is only used
+               -- to generate the BCO info table in the RTS at the moment.
+
+        | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
                 -- ptrs, nptrs, tag, closure type, description, type
                 {% withThisPackage $ \pkg ->
                    do dflags <- getDynFlags
                       let prof = profilingInfo dflags $13 $15
-                          ty  = Constr $9  -- Tag
+                          ty  = Constr (fromIntegral $9)  -- Tag
                                        (stringToWord8s $13)
-                          rep = mkRTSRep $11 $
+                          rep = mkRTSRep (fromIntegral $11) $
                                   mkHeapRep dflags False (fromIntegral $5)
                                                   (fromIntegral $7) ty
                       return (mkCmmEntryLabel pkg $3,
-                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
-                                           , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
-                              []) }
-
-                     -- If profiling is on, this string gets duplicated,
-                     -- but that's the way the old code did it we can fix it some other time.
-
-        | 'INFO_TABLE_SELECTOR' '(' NAME ',' stgWord ',' stgHalfWord ',' STRING ',' STRING ')'
-                -- selector, closure type, description, type
-                {% withThisPackage $ \pkg ->
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                          , cit_rep = rep
+                                                  , cit_prof = prof, cit_srt = NoC_SRT },
+                             []) }
+
+                    -- If profiling is on, this string gets duplicated,
+                    -- but that's the way the old code did it we can fix it some other time.
+       
+        | 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
+               -- selector, closure type, description, type
+               {% withThisPackage $ \pkg ->
                    do dflags <- getDynFlags
                       let prof = profilingInfo dflags $9 $11
-                          ty  = ThunkSelector $5
-                          rep = mkRTSRep $7 $
+                          ty  = ThunkSelector (fromIntegral $5)
+                          rep = mkRTSRep (fromIntegral $7) $
                                    mkHeapRep dflags False 0 0 ty
                       return (mkCmmEntryLabel pkg $3,
-                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
-                                           , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
-                              []) }
-
-        | 'INFO_TABLE_RET' '(' NAME ',' stgHalfWord ')'
-                -- closure type (no live regs)
-                {% withThisPackage $ \pkg ->
-                   do let prof = NoProfilingInfo
-                          rep  = mkRTSRep $5 $ mkStackRep []
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                          , cit_rep = rep
+                                                  , cit_prof = prof, cit_srt = NoC_SRT },
+                             []) }
+
+        | 'INFO_TABLE_RET' '(' NAME ',' INT ')'
+               -- closure type (no live regs)
+               {% withThisPackage $ \pkg ->
+                  do let prof = NoProfilingInfo
+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep []
                       return (mkCmmRetLabel pkg $3,
-                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
-                                           , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
-                              []) }
-
-        | 'INFO_TABLE_RET' '(' NAME ',' stgHalfWord ',' formals_without_hints0 ')'
-                -- closure type, live regs
-                {% withThisPackage $ \pkg ->
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                          , cit_rep = rep
+                                                  , cit_prof = prof, cit_srt = NoC_SRT },
+                             []) }
+
+        | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
+               -- closure type, live regs
+               {% withThisPackage $ \pkg ->
                    do dflags <- getDynFlags
-                      live <- sequence (map (liftM Just) $7)
-                      let prof = NoProfilingInfo
-                          bitmap = mkLiveness dflags live
-                          rep  = mkRTSRep $5 $ mkStackRep bitmap
+                      live <- sequence $7
+                     let prof = NoProfilingInfo
+                          -- drop one for the info pointer
+                          bitmap = mkLiveness dflags (map Just (drop 1 live))
+                          rep  = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
                       return (mkCmmRetLabel pkg $3,
-                              CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
-                                           , cit_rep = rep
-                                           , cit_prof = prof, cit_srt = NoC_SRT },
-                              []) }
+                              Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
+                                          , cit_rep = rep
+                                                  , cit_prof = prof, cit_srt = NoC_SRT },
+                              live) }
 
-body    :: { ExtCode }
-        : {- empty -}                   { return () }
-        | decl body                     { do $1; $2 }
-        | stmt body                     { do $1; $2 }
+body    :: { CmmParse () }
+       : {- empty -}                   { return () }
+       | decl body                     { do $1; $2 }
+       | stmt body                     { do $1; $2 }
 
-decl    :: { ExtCode }
-        : type names ';'                { mapM_ (newLocal $1) $2 }
-        | 'import' importNames ';'      { mapM_ newImport $2 }
-        | 'export' names ';'            { return () }  -- ignore exports
+decl    :: { CmmParse () }
+       : type names ';'                { mapM_ (newLocal $1) $2 }
+       | 'import' importNames ';'      { mapM_ newImport $2 }
+       | 'export' names ';'            { return () }  -- ignore exports
 
 
 -- an imported function name, with optional packageId
@@ -371,84 +522,96 @@ importNames
 importName
         :: { (FastString,  CLabel) }
 
-        -- A label imported without an explicit packageId.
-        --      These are taken to come frome some foreign, unnamed package.
-        : NAME
-        { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
-
-        -- A label imported with an explicit packageId.
-        | STRING NAME
-        { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) }
-
-
-names   :: { [FastString] }
-        : NAME                          { [$1] }
-        | NAME ',' names                { $1 : $3 }
-
-stmt    :: { ExtCode }
-        : ';'                                   { nopEC }
-
-        | NAME ':'
-                { do l <- newLabel $1; code (labelC l) }
-
-        | lreg '=' expr ';'
-                { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
-        | type '[' expr ']' '=' expr ';'
-                { doStore $1 $3 $6 }
-
-        -- Gah! We really want to say "maybe_results" but that causes
-        -- a shift/reduce conflict with assignment.  We either
-        -- we expand out the no-result and single result cases or
-        -- we tweak the syntax to avoid the conflict.  The later
-        -- option is taken here because the other way would require
-        -- multiple levels of expanding and get unwieldy.
-        | maybe_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety vols opt_never_returns ';'
-                {% foreignCall $3 $1 $4 $6 $9 $8 $10 }
-        | maybe_results 'prim' '%' NAME '(' cmm_hint_exprs0 ')' safety vols ';'
-                {% primCall $1 $4 $6 $9 $8 }
-        -- 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 '}'
-                { do as <- sequence $5; doSwitch $2 $3 as $6 }
-        | 'goto' NAME ';'
-                { do l <- lookupLabel $2; stmtEC (CmmBranch l) }
+       -- A label imported without an explicit packageId.
+       --      These are taken to come frome some foreign, unnamed package.
+       : NAME  
+       { ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
+
+       -- A label imported with an explicit packageId.
+       | STRING NAME
+       { ($2, mkCmmCodeLabel (fsToPackageId (mkFastString $1)) $2) }
+       
+       
+names  :: { [FastString] }
+       : NAME                          { [$1] }
+       | NAME ',' names                { $1 : $3 }
+
+stmt   :: { CmmParse () }
+        : ';'                                   { return () }
+
+       | NAME ':'
+                { do l <- newLabel $1; emitLabel l }
+
+
+
+       | lreg '=' expr ';'
+                { do reg <- $1; e <- $3; emitAssign reg e }
+       | type '[' expr ']' '=' expr ';'
+               { doStore $1 $3 $6 }
+
+        -- Gah! We really want to say "foreign_results" but that causes
+       -- a shift/reduce conflict with assignment.  We either
+       -- we expand out the no-result and single result cases or
+       -- we tweak the syntax to avoid the conflict.  The later
+       -- option is taken here because the other way would require
+       -- multiple levels of expanding and get unwieldy.
+        | foreign_results 'foreign' STRING expr '(' cmm_hint_exprs0 ')' safety opt_never_returns ';'
+                {% foreignCall $3 $1 $4 $6 $8 $9 }
+        | foreign_results 'prim' '%' NAME '(' exprs0 ')' ';'
+                {% primCall $1 $4 $6 }
+       -- 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 '}'
+               { do as <- sequence $5; doSwitch $2 $3 as $6 }
+       | 'goto' NAME ';'
+                { do l <- lookupLabel $2; emit (mkBranch l) }
+        | 'return' '(' exprs0 ')' ';'
+                { doReturn $3 }
         | 'jump' expr vols ';'
-                { do e <- $2; stmtEC (CmmJump e $3) }
-        | 'return' ';'
-                { stmtEC CmmReturn }
+                { doRawJump $2 $3 }
+        | 'jump' expr '(' exprs0 ')' ';'
+                { doJumpWithStack $2 [] $4 }
+        | 'jump' expr '(' exprs0 ')' '(' exprs0 ')' ';'
+                { doJumpWithStack $2 $4 $7 }
+        | 'call' expr '(' exprs0 ')' ';'
+                { doCall $2 [] $4 }
+        | '(' formals ')' '=' 'call' expr '(' exprs0 ')' ';'
+                { doCall $6 $2 $8 }
         | 'if' bool_expr 'goto' NAME
-                { do l <- lookupLabel $4; cmmRawIf $2 l }
-        | 'if' bool_expr '{' body '}' else
-                { cmmIfThenElse $2 $4 $6 }
+               { do l <- lookupLabel $4; cmmRawIf $2 l }
+       | 'if' bool_expr '{' body '}' else      
+               { cmmIfThenElse $2 $4 $6 }
+        | 'push' '(' exprs0 ')' maybe_body
+                { pushStackFrame $3 $5 }
 
 opt_never_returns :: { CmmReturnInfo }
         :                               { CmmMayReturn }
         | 'never' 'returns'             { CmmNeverReturns }
 
-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?
-safety  :: { CmmSafety }
-        : {- empty -}                   { CmmUnsafe } -- Default may change soon
-        | STRING                        {% parseSafety $1 }
-
--- This is not C-- syntax.  What to do?
-vols    :: { Maybe [GlobalReg] }
-        : {- empty -}                   { Nothing }
-        | '[' ']'                       { Just [] }
-        | '[' globals ']'               { Just $2 }
+bool_expr :: { CmmParse BoolExpr }
+       : bool_op                       { $1 }
+       | expr                          { do e <- $1; return (BoolTest e) }
+
+bool_op :: { CmmParse 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 }
+
+safety  :: { Safety }
+        : {- empty -}                   { PlayRisky }
+       | STRING                        {% parseSafety $1 }
+
+vols    :: { [GlobalReg] }
+        : '[' ']'                       { [] }
+        | '[' '*' ']'                   {% do df <- getDynFlags
+                                         ; return (realArgRegs df) }
+                                           -- all of them
+        | '[' globals ']'               { $2 }
 
 globals :: { [GlobalReg] }
         : GLOBALREG                     { [$1] }
@@ -458,67 +621,67 @@ maybe_range :: { Maybe (Int,Int) }
         : '[' INT '..' INT ']'  { Just (fromIntegral $2, fromIntegral $4) }
         | {- empty -}           { Nothing }
 
-arms    :: { [ExtFCode ([Int],Either BlockId ExtCode)] }
-        : {- empty -}                   { [] }
-        | arm arms                      { $1 : $2 }
+arms    :: { [CmmParse ([Int],Either BlockId (CmmParse ()))] }
+       : {- empty -}                   { [] }
+       | arm arms                      { $1 : $2 }
 
-arm     :: { ExtFCode ([Int],Either BlockId ExtCode) }
-        : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
+arm     :: { CmmParse ([Int],Either BlockId (CmmParse ())) }
+       : 'case' ints ':' arm_body      { do b <- $4; return ($2, b) }
 
-arm_body :: { ExtFCode (Either BlockId ExtCode) }
-        : '{' body '}'                  { return (Right $2) }
-        | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
+arm_body :: { CmmParse (Either BlockId (CmmParse ())) }
+       : '{' body '}'                  { return (Right $2) }
+       | 'goto' NAME ';'               { do l <- lookupLabel $2; return (Left l) }
 
 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 }
+default :: { Maybe (CmmParse ()) }
+       : 'default' ':' '{' body '}'    { Just $4 }
+       -- taking a few liberties with the C-- syntax here; C-- doesn't have
+       -- 'default' branches
+       | {- empty -}                   { Nothing }
 
 -- Note: OldCmm doesn't support a first class 'else' statement, though
 -- CmmNode does.
-else    :: { ExtCode }
-        : {- empty -}                   { nopEC }
-        | 'else' '{' body '}'           { $3 }
+else    :: { CmmParse () }
+        : {- empty -}                   { return () }
+       | '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 (typeWidth $2))) }
-        | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
-        | STRING                 { do s <- code (newStringCLit $1);
-                                      return (CmmLit s) }
-        | reg                    { $1 }
-        | type '[' expr ']'      { do e <- $3; return (CmmLoad e $1) }
-        | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }
-        | '(' expr ')'           { $2 }
+expr    :: { CmmParse 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  :: { CmmParse CmmExpr }
+       : INT   maybe_ty         { return (CmmLit (CmmInt $1 (typeWidth $2))) }
+       | FLOAT maybe_ty         { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
+       | STRING                 { do s <- code (newStringCLit $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--
@@ -526,81 +689,78 @@ maybe_ty :: { CmmType }
         : {- empty -}                   {% do dflags <- getDynFlags; return $ bWord dflags }
         | '::' type                     { $2 }
 
-maybe_actuals :: { [ExtFCode HintedCmmActual] }
-        : {- empty -}                   { [] }
-        | '(' cmm_hint_exprs0 ')'       { $2 }
-
-cmm_hint_exprs0 :: { [ExtFCode HintedCmmActual] }
-        : {- empty -}                   { [] }
+cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
+       : {- empty -}                   { [] }
         | cmm_hint_exprs                { $1 }
 
-cmm_hint_exprs :: { [ExtFCode HintedCmmActual] }
-        : cmm_hint_expr                         { [$1] }
-        | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
+cmm_hint_exprs :: { [CmmParse (CmmExpr, ForeignHint)] }
+       : cmm_hint_expr                 { [$1] }
+       | cmm_hint_expr ',' cmm_hint_exprs      { $1 : $3 }
 
-cmm_hint_expr :: { ExtFCode HintedCmmActual }
-        : expr                          { do e <- $1; return (CmmHinted e (inferCmmHint e)) }
-        | expr STRING                   {% do h <- parseCmmHint $2;
-                                              return $ do
-                                                e <- $1; return (CmmHinted e h) }
+cmm_hint_expr :: { CmmParse (CmmExpr, ForeignHint) }
+        : expr                          { do e <- $1;
+                                             return (e, inferCmmHint e) }
+       | expr STRING                   {% do h <- parseCmmHint $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)) }
-
-maybe_results :: { [ExtFCode HintedCmmFormal] }
-        : {- empty -}           { [] }
-        | '(' cmm_formals ')' '='       { $2 }
-
-cmm_formals :: { [ExtFCode HintedCmmFormal] }
-        : cmm_formal                    { [$1] }
-        | cmm_formal ','                { [$1] }
-        | cmm_formal ',' cmm_formals    { $1 : $3 }
-
-cmm_formal :: { ExtFCode HintedCmmFormal }
-        : local_lreg                    { do e <- $1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) }
-        | STRING local_lreg             {% do h <- parseCmmHint $1;
-                                              return $ do
-                                                e <- $2; return (CmmHinted e h) }
-
-local_lreg :: { ExtFCode LocalReg }
-        : NAME                  { do e <- lookupName $1;
-                                     return $
-                                       case e of
-                                        CmmReg (CmmLocal r) -> r
-                                        other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
-
-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) }
-
-maybe_formals_without_hints :: { [ExtFCode LocalReg] }
-        : {- empty -}                           { [] }
-        | '(' formals_without_hints0 ')'        { $2 }
-
-formals_without_hints0 :: { [ExtFCode LocalReg] }
-        : {- empty -}                   { [] }
-        | formals_without_hints         { $1 }
+exprs0  :: { [CmmParse CmmExpr] }
+       : {- empty -}                   { [] }
+       | exprs                         { $1 }
 
-formals_without_hints :: { [ExtFCode LocalReg] }
-        : formal_without_hint ','                       { [$1] }
-        | formal_without_hint                           { [$1] }
-        | formal_without_hint ',' formals_without_hints { $1 : $3 }
+exprs   :: { [CmmParse CmmExpr] }
+       : expr                          { [ $1 ] }
+       | expr ',' exprs                { $1 : $3 }
 
-formal_without_hint :: { ExtFCode LocalReg }
-        : type NAME             { newLocal $1 $2 }
+reg     :: { CmmParse CmmExpr }
+       : NAME                  { lookupName $1 }
+       | GLOBALREG             { return (CmmReg (CmmGlobal $1)) }
+
+foreign_results :: { [CmmParse (LocalReg, ForeignHint)] }
+        : {- empty -}                   { [] }
+        | '(' foreign_formals ')' '='   { $2 }
+
+foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
+       : foreign_formal                        { [$1] }
+        | foreign_formal ','                    { [$1] }
+        | foreign_formal ',' foreign_formals    { $1 : $3 }
+
+foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
+        : local_lreg            { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }
+        | STRING local_lreg     {% do h <- parseCmmHint $1;
+                                      return $ do
+                                         e <- $2; return (e,h) }
+
+local_lreg :: { CmmParse LocalReg }
+       : NAME                  { do e <- lookupName $1;
+                                    return $
+                                      case e of 
+                                       CmmReg (CmmLocal r) -> r
+                                       other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
+
+lreg   :: { CmmParse 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) }
+
+maybe_formals :: { Maybe [CmmParse LocalReg] }
+        : {- empty -}           { Nothing }
+        | '(' formals0 ')'      { Just $2 }
+
+formals0 :: { [CmmParse LocalReg] }
+       : {- empty -}           { [] }
+        | formals               { $1 }
+
+formals :: { [CmmParse LocalReg] }
+        : formal ','            { [$1] }
+        | formal                { [$1] }
+        | formal ',' formals       { $1 : $3 }
+
+formal :: { CmmParse LocalReg }
+       : type NAME             { newLocal $1 $2 }
 
 type    :: { CmmType }
         : 'bits8'               { b8 }
@@ -614,12 +774,6 @@ typenot8 :: { CmmType }
         | 'float64'             { f64 }
         | 'gcptr'               {% do dflags <- getDynFlags; return $ gcWord dflags }
 
-stgWord :: { StgWord }
-        : INT                   {% do dflags <- getDynFlags; return $ toStgWord dflags $1 }
-
-stgHalfWord :: { StgHalfWord }
-        : INT                   {% do dflags <- getDynFlags; return $ toStgHalfWord dflags $1 }
-
 {
 section :: String -> Section
 section "text"      = Text
@@ -632,11 +786,22 @@ section s           = OtherSection s
 mkString :: String -> CmmStatic
 mkString s = CmmString (map (fromIntegral.ord) s)
 
+-- |
+-- Given an info table, decide what the entry convention for the proc
+-- is.  That is, for an INFO_TABLE_RET we want the return convention,
+-- otherwise it is a NativeNodeCall.
+--
+infoConv :: Maybe CmmInfoTable -> Convention
+infoConv Nothing = NativeNodeCall
+infoConv (Just info)
+  | isStackRep (cit_rep info) = NativeReturn
+  | otherwise                 = NativeNodeCall
+
 -- 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 :: (Width -> MachOp) -> [ExtFCode CmmExpr] -> ExtFCode CmmExpr
+mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
 mkMachOp fn args = do
   dflags <- getDynFlags
   arg_exprs <- sequence args
@@ -653,7 +818,7 @@ nameToMachOp name =
         Nothing -> fail ("unknown primitive " ++ unpackFS name)
         Just m  -> return m
 
-exprOp :: FastString -> [ExtFCode CmmExpr] -> P (ExtFCode CmmExpr)
+exprOp :: FastString -> [CmmParse CmmExpr] -> P (CmmParse CmmExpr)
 exprOp name args_code = do
   dflags <- getDynFlags
   case lookupUFM (exprMacros dflags) name of
@@ -755,10 +920,10 @@ callishMachOps = listToUFM $
         -- ToDo: the rest, maybe
     ]
 
-parseSafety :: String -> P CmmSafety
-parseSafety "safe"   = return (CmmSafe NoC_SRT)
-parseSafety "unsafe" = return CmmUnsafe
-parseSafety "interruptible" = return CmmInterruptible
+parseSafety :: String -> P Safety
+parseSafety "safe"   = return PlaySafe
+parseSafety "unsafe" = return PlayRisky
+parseSafety "interruptible" = return PlayInterruptible
 parseSafety str      = fail ("unrecognised safety: " ++ str)
 
 parseCmmHint :: String -> P ForeignHint
@@ -788,7 +953,7 @@ happyError = srcParseFail
 -- -----------------------------------------------------------------------------
 -- Statement-level macros
 
-stmtMacro :: FastString -> [ExtFCode CmmExpr] -> P ExtCode
+stmtMacro :: FastString -> [CmmParse CmmExpr] -> P (CmmParse ())
 stmtMacro fun args_code = do
   case lookupUFM stmtMacros fun of
     Nothing -> fail ("unknown macro: " ++ unpackFS fun)
@@ -796,49 +961,61 @@ stmtMacro fun args_code = do
         args <- sequence args_code
         code (fcode args)
 
-stmtMacros :: UniqFM ([CmmExpr] -> Code)
+stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
 stmtMacros = listToUFM [
   ( fsLit "CCS_ALLOC",             \[words,ccs]  -> profAlloc words ccs ),
+  ( fsLit "ENTER_CCS_THUNK",       \[e] -> enterCostCentreThunk e ),
+
   ( fsLit "CLOSE_NURSERY",         \[]  -> emitCloseNursery ),
-  ( 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 ),
+
+  -- completely generic heap and stack checks, for use in high-level cmm.
+  ( fsLit "HP_CHK_GEN",            \[bytes] ->
+                                      heapStackCheckGen Nothing (Just bytes) ),
+  ( fsLit "STK_CHK_GEN",           \[] ->
+                                      heapStackCheckGen (Just (CmmLit CmmHighStackMark)) Nothing ),
+
+  -- A stack check for a fixed amount of stack.  Sounds a bit strange, but
+  -- we use the stack for a bit of temporary storage in a couple of primops
+  ( fsLit "STK_CHK_GEN_N",         \[bytes] ->
+                                      heapStackCheckGen (Just bytes) Nothing ),
+
+  -- A stack check on entry to a thunk, where the argument is the thunk pointer.
+  ( fsLit "STK_CHK_NP"   ,         \[node] -> entryHeapCheck' False node 0 [] (return ())),
+
+  ( fsLit "LOAD_THREAD_STATE",     \[] -> emitLoadThreadState ),
+  ( fsLit "SAVE_THREAD_STATE",     \[] -> emitSaveThreadState ),
+
+  ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),
+  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),
+
   ( 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 ),
+                                       emitSetDynHdr ptr info ccs ),
   ( 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_NPP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(PtrArg,b),(PtrArg,c)]),
-  ( fsLit "RET_NNP",    \[a,b,c] ->   emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(PtrArg,c)]),
-  ( fsLit "RET_NNN",  \[a,b,c] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c)]),
-  ( fsLit "RET_NNNN",  \[a,b,c,d] -> emitRetUT [(NonPtrArg,a),(NonPtrArg,b),(NonPtrArg,c),(NonPtrArg,d)]),
-  ( 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)])
-
+                                       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",      \[reg] -> emitBlackHoleCode False reg ),
+  ( fsLit "UPD_BH_SINGLE_ENTRY",   \[reg] -> emitBlackHoleCode True  reg )
  ]
 
+emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
+emitPushUpdateFrame sp e = do
+  dflags <- getDynFlags
+  emitUpdateFrame dflags sp mkUpdInfoLabel e
+
+pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
+pushStackFrame fields body = do
+  dflags <- getDynFlags
+  exprs <- sequence fields
+  updfr_off <- getUpdFrameOff
+  let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
+                                           [] updfr_off exprs
+  emit g
+  withUpdFrameOff new_updfr_off body
 
 profilingInfo dflags desc_str ty_str
   = if not (dopt Opt_SccProfilingOn dflags)
@@ -846,7 +1023,7 @@ profilingInfo dflags desc_str ty_str
     else ProfilingInfo (stringToWord8s desc_str)
                        (stringToWord8s ty_str)
 
-staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> ExtCode
+staticClosure :: PackageId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
 staticClosure pkg cl_label info payload
   = do dflags <- getDynFlags
        let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
@@ -854,78 +1031,93 @@ staticClosure pkg cl_label info payload
 
 foreignCall
         :: String
-        -> [ExtFCode HintedCmmFormal]
-        -> ExtFCode CmmExpr
-        -> [ExtFCode HintedCmmActual]
-        -> Maybe [GlobalReg]
-        -> CmmSafety
+        -> [CmmParse (LocalReg, ForeignHint)]
+       -> CmmParse CmmExpr
+        -> [CmmParse (CmmExpr, ForeignHint)]
+        -> Safety
         -> CmmReturnInfo
-        -> P ExtCode
-foreignCall conv_string results_code expr_code args_code vols safety ret
-  = do  convention <- case conv_string of
+        -> P (CmmParse ())
+foreignCall conv_string results_code expr_code args_code safety ret
+  = do  conv <- case conv_string of
           "C" -> return CCallConv
           "stdcall" -> return StdCallConv
-          "C--" -> return CmmCallConv
           _ -> fail ("unknown calling convention: " ++ conv_string)
         return $ do
           dflags <- getDynFlags
-          let platform = targetPlatform dflags
           results <- sequence results_code
-          expr <- expr_code
-          args <- sequence args_code
-          case convention of
-            -- Temporary hack so at least some functions are CmmSafe
-            CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args ret))
-            _ ->
-              let expr' = adjCallTarget dflags convention expr args in
-              case safety of
-              CmmUnsafe ->
-                code (emitForeignCall' PlayRisky results
-                   (CmmCallee expr' convention) args vols NoC_SRT ret)
-              CmmSafe srt ->
-                code (emitForeignCall' PlaySafe results
-                   (CmmCallee expr' convention) args vols NoC_SRT ret) where
-              CmmInterruptible ->
-                code (emitForeignCall' PlayInterruptible results
-                   (CmmCallee expr' convention) args vols NoC_SRT ret)
-
-adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [CmmHinted CmmExpr]
+         expr <- expr_code
+         args <- sequence args_code
+          let
+                  expr' = adjCallTarget dflags conv expr args
+                  (arg_exprs, arg_hints) = unzip args
+                  (res_regs,  res_hints) = unzip results
+                  fc = ForeignConvention conv arg_hints res_hints ret
+                  target = ForeignTarget expr' fc
+          _ <- code $ emitForeignCall safety res_regs target arg_exprs
+          return ()
+
+
+doReturn :: [CmmParse CmmExpr] -> CmmParse ()
+doReturn exprs_code = do
+  dflags <- getDynFlags
+  exprs <- sequence exprs_code
+  updfr_off <- getUpdFrameOff
+  emit (mkReturnSimple dflags exprs updfr_off)
+
+doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
+doRawJump expr_code vols = do
+  dflags <- getDynFlags
+  expr <- expr_code
+  updfr_off <- getUpdFrameOff
+  emit (mkRawJump dflags expr updfr_off vols)
+
+doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
+                -> [CmmParse CmmExpr] -> CmmParse ()
+doJumpWithStack expr_code stk_code args_code = do
+  dflags <- getDynFlags
+  expr <- expr_code
+  stk_args <- sequence stk_code
+  args <- sequence args_code
+  updfr_off <- getUpdFrameOff
+  emit (mkJumpExtra dflags expr args updfr_off stk_args)
+
+doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
+       -> CmmParse ()
+doCall expr_code res_code args_code = do
+  dflags <- getDynFlags
+  expr <- expr_code
+  args <- sequence args_code
+  ress <- sequence res_code
+  updfr_off <- getUpdFrameOff
+  c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
+  emit c
+
+adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
               -> CmmExpr
 -- On Windows, we have to add the '@N' suffix to the label when making
 -- a call with the stdcall calling convention.
 adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
  | platformOS (targetPlatform dflags) == OSMinGW32
   = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
-  where size (CmmHinted e _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
+  where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
                  -- c.f. CgForeignCall.emitForeignCall
 adjCallTarget _ _ expr _
   = expr
 
 primCall
-        :: [ExtFCode HintedCmmFormal]
-        -> FastString
-        -> [ExtFCode HintedCmmActual]
-        -> Maybe [GlobalReg]
-        -> CmmSafety
-        -> P ExtCode
-primCall results_code name args_code vols safety
+        :: [CmmParse (CmmFormal, ForeignHint)]
+       -> FastString
+        -> [CmmParse CmmExpr]
+        -> P (CmmParse ())
+primCall results_code name args_code
   = case lookupUFM callishMachOps name of
         Nothing -> fail ("unknown primitive " ++ unpackFS name)
-        Just p  -> return $ do
-                results <- sequence results_code
-                args <- sequence args_code
-                case safety of
-                  CmmUnsafe ->
-                    code (emitForeignCall' PlayRisky results
-                      (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn)
-                  CmmSafe srt ->
-                    code (emitForeignCall' PlaySafe results
-                      (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn) where
-                  CmmInterruptible ->
-                    code (emitForeignCall' PlayInterruptible results
-                      (CmmPrim p Nothing) args vols NoC_SRT CmmMayReturn)
-
-doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
+       Just p  -> return $ do
+               results <- sequence results_code
+               args <- sequence args_code
+                code (emitPrimCall (map fst results) p args)
+
+doStore :: CmmType -> CmmParse CmmExpr  -> CmmParse CmmExpr -> CmmParse ()
 doStore rep addr_code val_code
   = do dflags <- getDynFlags
        addr <- addr_code
@@ -940,19 +1132,7 @@ doStore rep addr_code val_code
        let coerce_val
                 | val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
                 | otherwise              = val
-       stmtEC (CmmStore addr coerce_val)
-
--- Return an unboxed tuple.
-emitRetUT :: [(CgRep,CmmExpr)] -> Code
-emitRetUT args = do
-  dflags <- getDynFlags
-  tickyUnboxedTupleReturn (length args)  -- TICK
-  (sp, stmts, live) <- pushUnboxedTuple 0 args
-  emitSimultaneously stmts -- NB. the args might overlap with the stack slots
-                           -- or regs that we assign to, so better use
-                           -- simultaneous assignments here (#3546)
-  when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW dflags spReg (-sp)))
-  stmtC $ CmmJump (entryCode dflags (CmmLoad (cmmRegOffW dflags spReg sp) (bWord dflags))) (Just live)
+       emitStore addr coerce_val
 
 -- -----------------------------------------------------------------------------
 -- If-then-else and boolean expressions
@@ -966,16 +1146,16 @@ data BoolExpr
 -- ToDo: smart constructors which simplify the boolean expression.
 
 cmmIfThenElse cond then_part else_part = do
-     then_id <- code newLabelC
-     join_id <- code newLabelC
+     then_id <- newBlockId
+     join_id <- newBlockId
      c <- cond
      emitCond c then_id
      else_part
-     stmtEC (CmmBranch join_id)
-     code (labelC then_id)
+     emit (mkBranch join_id)
+     emitLabel then_id
      then_part
      -- fall through to join
-     code (labelC join_id)
+     emitLabel join_id
 
 cmmRawIf cond then_id = do
     c <- cond
@@ -984,30 +1164,32 @@ cmmRawIf cond then_id = do
 -- '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)
+  else_id <- newBlockId
+  emit (mkCbranch e then_id else_id)
+  emitLabel else_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
+  else_id <- newBlockId
   emitCond e else_id
-  stmtEC (CmmBranch then_id)
-  code (labelC else_id)
+  emit (mkBranch then_id)
+  emitLabel 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
+       -- 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 <- newBlockId
+  else_id <- newBlockId
   emitCond e1 and_id
-  stmtEC (CmmBranch else_id)
-  code (labelC and_id)
+  emit (mkBranch else_id)
+  emitLabel and_id
   emitCond e2 then_id
-  code (labelC else_id)
+  emitLabel else_id
 
 
 -- -----------------------------------------------------------------------------
@@ -1020,38 +1202,45 @@ emitCond (e1 `BoolAnd` e2) then_id = do
 -- 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],Either BlockId ExtCode)]
-         -> Maybe ExtCode -> ExtCode
+doSwitch :: Maybe (Int,Int) -> CmmParse CmmExpr -> [([Int],Either BlockId (CmmParse ()))]
+         -> Maybe (CmmParse ()) -> CmmParse ()
 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)
+       -- Compile code for the default branch
+       dflt_entry <- 
+               case deflt of
+                 Nothing -> return Nothing
+                  Just e  -> do b <- forkLabelledCode 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
+        emit (mkSwitch expr entries)
    where
-        emitArm :: ([Int],Either BlockId ExtCode) -> ExtFCode [(Int,BlockId)]
-        emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
-        emitArm (ints,Right code) = do
-           blockid <- forkLabelledCodeEC code
-           return [ (i,blockid) | i <- ints ]
+        emitArm :: ([Int],Either BlockId (CmmParse ())) -> CmmParse [(Int,BlockId)]
+       emitArm (ints,Left blockid) = return [ (i,blockid) | i <- ints ]
+       emitArm (ints,Right code) = do
+           blockid <- forkLabelledCode code
+          return [ (i,blockid) | i <- ints ]
+
+forkLabelledCode :: CmmParse () -> CmmParse BlockId
+forkLabelledCode p = do
+  ag <- getCode p
+  l <- newBlockId
+  emitOutOfLine l ag
+  return l
 
 -- -----------------------------------------------------------------------------
 -- Putting it all together
index 5fca9e7..4f5d3b9 100644 (file)
@@ -52,7 +52,7 @@ cmmPipeline hsc_env topSRT prog =
 
 cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
 cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
-cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
+cpsTop hsc_env proc =
     do
        ----------- Control-flow optimisations ----------------------------------
 
@@ -60,10 +60,13 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
        -- later passes by removing lots of empty blocks, so we do it
        -- even when optimisation isn't turned on.
        --
-       g <- {-# SCC "cmmCfgOpts(1)" #-}
-            return $ cmmCfgOpts splitting_proc_points g
+       CmmProc h l g <- {-# SCC "cmmCfgOpts(1)" #-}
+            return $ cmmCfgOptsProc splitting_proc_points proc
        dump Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
 
+       let !TopInfo {stack_info=StackInfo { arg_space = entry_off
+                                          , do_layout = do_layout }} = h
+
        ----------- Eliminate common blocks -------------------------------------
        g <- {-# SCC "elimCommonBlocks" #-}
             condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
@@ -95,7 +98,9 @@ cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}})
        ----------- Layout the stack and manifest Sp ----------------------------
        (g, stackmaps) <-
             {-# SCC "layoutStack" #-}
-            runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
+            if do_layout
+               then runUniqSM $ cmmLayoutStack dflags proc_points entry_off g
+               else return (g, mapEmpty)
        dump Opt_D_dump_cmmz_sp "Layout Stack" g
 
        ----------- Sink and inline assignments *after* stack layout ------------
index 471faf8..19f0155 100644 (file)
@@ -291,7 +291,8 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
      let to_proc (bid, g) = case expectJust "pp label" $ mapLookup bid procLabels of
              (lbl, Just info_lbl)
                | bid == entry
-               -> CmmProc (TopInfo {info_tbls=info_tbls, stack_info=stack_info})
+               -> CmmProc (TopInfo {info_tbls  = info_tbls,
+                                    stack_info = stack_info})
                           top_l (replacePPIds g)
                | otherwise
                -> CmmProc (TopInfo {info_tbls = mapSingleton (g_entry g) (mkEmptyContInfoTable info_lbl), stack_info=stack_info})
@@ -300,7 +301,9 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
                -> CmmProc (TopInfo {info_tbls = mapEmpty, stack_info=stack_info})
                           lbl (replacePPIds g)
             where
-             stack_info = StackInfo 0 Nothing -- panic "No StackInfo"
+             stack_info = StackInfo { arg_space = 0
+                                    , updfr_space =  Nothing
+                                    , do_layout = True }
                           -- cannot use panic, this is printed by -ddump-cmmz
 
          -- References to procpoint IDs can now be replaced with the
index 2ff9b98..6dccdab 100644 (file)
@@ -6,6 +6,7 @@ module CmmSink (
 import CodeGen.Platform (callerSaves)
 
 import Cmm
+import CmmOpt
 import BlockId
 import CmmLive
 import CmmUtils
@@ -13,8 +14,7 @@ import Hoopl
 
 import DynFlags
 import UniqFM
--- import PprCmm ()
--- import Outputable
+import PprCmm ()
 
 import Data.List (partition)
 import qualified Data.Set as Set
@@ -76,9 +76,11 @@ import qualified Data.Set as Set
 -- *but*, that will invalidate the liveness analysis, and we'll have
 -- to re-do it.
 
--- TODO: things that we aren't optimising very well yet.
+-- -----------------------------------------------------------------------------
+-- things that we aren't optimising very well yet.
 --
--- From GHC's FastString.hashStr:
+-- -----------
+-- (1) From GHC's FastString.hashStr:
 --
 --  s2ay:
 --      if ((_s2an::I64 == _s2ao::I64) >= 1) goto c2gn; else goto c2gp;
@@ -95,6 +97,26 @@ import qualified Data.Set as Set
 -- a nice loop, but we didn't eliminate the silly assignment at the end.
 -- See Note [dependent assignments], which would probably fix this.
 --
+-- -----------
+-- (2) From stg_atomically_frame in PrimOps.cmm
+--
+-- We have a diamond control flow:
+--
+--     x = ...
+--       |
+--      / \
+--     A   B
+--      \ /
+--       |
+--    use of x
+--
+-- Now x won't be sunk down to its use, because we won't push it into
+-- both branches of the conditional.  We certainly do have to check
+-- that we can sink it past all the code in both A and B, but having
+-- discovered that, we could sink it to its use.
+--
+
+-- -----------------------------------------------------------------------------
 
 type Assignment = (LocalReg, CmmExpr, AbsMem)
   -- Assignment caches AbsMem, an abstraction of the memory read by
@@ -130,7 +152,8 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
 
       -- Now sink and inline in this block
       (middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)
-      (final_last, assigs') = tryToInline dflags live last assigs
+      fold_last = constantFold dflags last
+      (final_last, assigs') = tryToInline dflags live fold_last assigs
 
       -- We cannot sink into join points (successors with more than
       -- one predecessor), so identify the join points and the set
@@ -246,13 +269,24 @@ walk dflags nodes assigs = go nodes emptyBlock assigs
    go []               block as = (block, as)
    go ((live,node):ns) block as
     | shouldDiscard node live    = go ns block as
-    | Just a <- shouldSink dflags node1 = go ns block (a : as1)
+    | Just a <- shouldSink dflags node2 = go ns block (a : as1)
     | otherwise                         = go ns block' as'
     where
-      (node1, as1) = tryToInline dflags live node as
+      node1 = constantFold dflags node
+
+      (node2, as1) = tryToInline dflags live node1 as
+
+      (dropped, as') = dropAssignmentsSimple dflags
+                          (\a -> conflicts dflags a node2) as1
+
+      block' = foldl blockSnoc block dropped `blockSnoc` node2
+
 
-      (dropped, as') = dropAssignmentsSimple dflags (\a -> conflicts dflags a node1) as1
-      block' = foldl blockSnoc block dropped `blockSnoc` node1
+constantFold :: DynFlags -> CmmNode e x -> CmmNode e x
+constantFold dflags node = mapExpDeep f node
+  where f (CmmMachOp op args) = cmmMachOpFold dflags op args
+        f (CmmRegOff r 0) = CmmReg r
+        f e = e
 
 --
 -- Heuristic to decide whether to pick up and sink an assignment
@@ -352,6 +386,8 @@ tryToInline dflags live node assigs = go usages node [] assigs
            where inline (CmmReg    (CmmLocal l'))     | l == l' = rhs
                  inline (CmmRegOff (CmmLocal l') off) | l == l'
                     = cmmOffset dflags rhs off
+                    -- re-constant fold after inlining
+                 inline (CmmMachOp op args) = cmmMachOpFold dflags op args
                  inline other = other
 
   go usages node skipped (assig@(l,rhs,_) : rest)
@@ -416,7 +452,8 @@ conflicts dflags (r, rhs, addr) node
   | foldRegsUsed (\b r' -> r == r' || b) False node               = True
 
   -- (2) a store to an address conflicts with a read of the same memory
-  | CmmStore addr' e <- node, memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True
+  | CmmStore addr' e <- node
+  , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True
 
   -- (3) an assignment to Hp/Sp conflicts with a heap/stack read respectively
   | HeapMem    <- addr, CmmAssign (CmmGlobal Hp) _ <- node        = True
@@ -526,5 +563,6 @@ loadAddr dflags e w =
 regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem
 regAddr _      (CmmGlobal Sp) i w = SpMem i (widthInBytes w)
 regAddr _      (CmmGlobal Hp) _ _ = HeapMem
+regAddr _      (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps
 regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself
 regAddr _      _ _ _ = AnyMem
index d6da5a4..9a443c1 100644 (file)
@@ -15,6 +15,8 @@ module CmmType
     , rEP_CostCentreStack_mem_alloc
     , rEP_CostCentreStack_scc_count
     , rEP_StgEntCounter_allocs
+
+    , ForeignHint(..)
    )
 where
 
@@ -52,7 +54,8 @@ instance Outputable CmmType where
 
 instance Outputable CmmCat where
   ppr FloatCat  = ptext $ sLit("F")
-  ppr _         = ptext $ sLit("I")
+  ppr GcPtrCat  = ptext $ sLit("P")
+  ppr BitsCat   = ptext $ sLit("I")
 
 -- Why is CmmType stratified?  For native code generation,
 -- most of the time you just want to know what sort of register
@@ -242,6 +245,19 @@ narrowS W64 x = fromIntegral (fromIntegral x :: Int64)
 narrowS _ _ = panic "narrowTo"
 
 -------------------------------------------------------------------------
+-- Hints
+
+-- Hints are extra type information we attach to the arguments and
+-- results of a foreign call, where more type information is sometimes
+-- needed by the ABI to make the correct kind of call.
+
+data ForeignHint
+  = NoHint | AddrHint | SignedHint
+  deriving( Eq )
+        -- Used to give extra per-argument or per-result
+        -- information needed by foreign calling conventions
+
+-------------------------------------------------------------------------
 
 -- These don't really belong here, but I don't know where is best to
 -- put them.
index bf93a2f..f420e7d 100644 (file)
@@ -22,6 +22,7 @@ module CmmUtils(
         mkWordCLit, packHalfWordsCLit,
         mkByteStringCLit,
         mkDataLits, mkRODataLits,
+        mkStgWordCLit,
 
         -- CmmExpr
         mkIntExpr, zeroExpr,
@@ -120,6 +121,8 @@ typeForeignHint = primRepForeignHint . typePrimRep
 --
 ---------------------------------------------------
 
+-- XXX: should really be Integer, since Int doesn't necessarily cover
+-- the full range of target Ints.
 mkIntCLit :: DynFlags -> Int -> CmmLit
 mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
 
@@ -132,6 +135,9 @@ zeroCLit dflags = CmmInt 0 (wordWidth dflags)
 zeroExpr :: DynFlags -> CmmExpr
 zeroExpr dflags = CmmLit (zeroCLit dflags)
 
+mkWordCLit :: DynFlags -> Integer -> CmmLit
+mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)
+
 mkByteStringCLit :: Unique -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
 -- We have to make a top-level decl for the string,
 -- and return a literal pointing to it
@@ -155,8 +161,8 @@ mkRODataLits lbl lits
     needsRelocation (CmmLabelOff _ _) = True
     needsRelocation _                 = False
 
-mkWordCLit :: DynFlags -> StgWord -> CmmLit
-mkWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
+mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
+mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
 
 packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
 -- Make a single word literal in which the lower_half_word is
@@ -168,8 +174,8 @@ packHalfWordsCLit dflags lower_half_word upper_half_word
    = if wORDS_BIGENDIAN dflags
      then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u)
      else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags))
-    where l = toStgWord dflags (fromStgHalfWord lower_half_word)
-          u = toStgWord dflags (fromStgHalfWord upper_half_word)
+    where l = fromStgHalfWord lower_half_word
+          u = fromStgHalfWord upper_half_word
 
 ---------------------------------------------------
 --
@@ -197,6 +203,9 @@ cmmOffset _ e                 0        = e
 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 _ (CmmStackSlot area off) byte_off
+  = CmmStackSlot area (off - byte_off)
+  -- note stack area offsets increase towards lower addresses
 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)]
@@ -207,6 +216,7 @@ cmmOffset dflags expr byte_off
 
 -- Smart constructor for CmmRegOff.  Same caveats as cmmOffset above.
 cmmRegOff :: CmmReg -> Int -> CmmExpr
+cmmRegOff reg 0        = CmmReg reg
 cmmRegOff reg byte_off = CmmRegOff reg byte_off
 
 cmmOffsetLit :: CmmLit -> Int -> CmmLit
index 4ba82cd..1e2ddfa 100644 (file)
@@ -9,9 +9,10 @@ module MkGraph
   , stackStubExpr
   , mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, mkCallReturnsTo
   , mkJumpReturnsTo
-  , mkJump, mkDirectJump, mkForeignJump, mkForeignJumpExtra, mkJumpGC
+  , mkJump, mkJumpExtra, mkDirectJump, mkForeignJump, mkForeignJumpExtra
+  , mkRawJump
   , mkCbranch, mkSwitch
-  , mkReturn, mkComment, mkCallEntry, mkBranch
+  , mkReturn, mkReturnSimple, mkComment, mkCallEntry, mkBranch
   , copyInOflow, copyOutOflow
   , noExtraStack
   , toCall, Transfer(..)
@@ -20,7 +21,7 @@ where
 
 import BlockId
 import Cmm
-import CmmCallConv (assignArgumentsPos, ParamLocation(..))
+import CmmCallConv
 
 
 import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
@@ -161,11 +162,11 @@ outOfLine l g   = unitOL (CgFork l g)
 -- | allocate a fresh label for the entry point
 lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
 lgraphOfAGraph g = do u <- getUniqueM
-                      return (flattenCmmAGraph (mkBlockId u) g)
+                      return (labelAGraph (mkBlockId u) g)
 
 -- | use the given BlockId as the label of the entry point
-labelAGraph    :: BlockId -> CmmAGraph -> UniqSM CmmGraph
-labelAGraph lbl ag = return (flattenCmmAGraph lbl ag)
+labelAGraph    :: BlockId -> CmmAGraph -> CmmGraph
+labelAGraph lbl ag = flattenCmmAGraph lbl ag
 
 ---------- No-ops
 mkNop        :: CmmAGraph
@@ -194,16 +195,25 @@ mkJump dflags e actuals updfr_off =
   lastWithArgs dflags Jump Old NativeNodeCall actuals updfr_off $
     toCall e Nothing updfr_off 0
 
-mkDirectJump    :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
+-- | A jump where the caller says what the live GlobalRegs are.  Used
+-- for low-level hand-written Cmm.
+mkRawJump       :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
                 -> CmmAGraph
-mkDirectJump dflags e actuals updfr_off =
-  lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $
+mkRawJump dflags e updfr_off vols =
+  lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $
+    \arg_space _  -> toCall e Nothing updfr_off 0 arg_space vols
+
+
+mkJumpExtra     :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
+                -> [CmmActual] -> CmmAGraph
+mkJumpExtra dflags e actuals updfr_off extra_stack =
+  lastWithArgsAndExtraStack dflags Jump Old NativeNodeCall actuals updfr_off extra_stack $
     toCall e Nothing updfr_off 0
 
-mkJumpGC        :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
+mkDirectJump    :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
                 -> CmmAGraph
-mkJumpGC dflags e actuals updfr_off =
-  lastWithArgs dflags Jump Old GC actuals updfr_off $
+mkDirectJump dflags e actuals updfr_off =
+  lastWithArgs dflags Jump Old NativeDirectCall actuals updfr_off $
     toCall e Nothing updfr_off 0
 
 mkForeignJump   :: DynFlags
@@ -213,7 +223,7 @@ mkForeignJump dflags conv e actuals updfr_off =
   mkForeignJumpExtra dflags conv e actuals updfr_off noExtraStack
 
 mkForeignJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
-                -> UpdFrameOffset -> (ByteOff, [(CmmExpr, ByteOff)])
+                -> UpdFrameOffset -> [CmmActual]
                 -> CmmAGraph
 mkForeignJumpExtra dflags conv e actuals updfr_off extra_stack =
   lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
@@ -231,6 +241,11 @@ mkReturn dflags e actuals updfr_off =
   lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $
     toCall e Nothing updfr_off 0
 
+mkReturnSimple  :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
+mkReturnSimple dflags actuals updfr_off =
+  mkReturn dflags e actuals updfr_off
+  where e = CmmLoad (CmmStackSlot Old updfr_off) (gcWord dflags)
+
 mkBranch        :: BlockId -> CmmAGraph
 mkBranch bid     = mkLast (CmmBranch bid)
 
@@ -245,7 +260,7 @@ mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
                 -> BlockId
                 -> ByteOff
                 -> UpdFrameOffset
-                -> (ByteOff, [(CmmExpr,ByteOff)])
+                -> [CmmActual]
                 -> CmmAGraph
 mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
   lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
@@ -282,39 +297,40 @@ stackStubExpr :: Width -> CmmExpr
 stackStubExpr w = CmmLit (CmmInt 0 w)
 
 -- When we copy in parameters, we usually want to put overflow
--- parameters on the stack, but sometimes we want to pass
--- the variables in their spill slots.
--- Therefore, for copying arguments and results, we provide different
--- functions to pass the arguments in an overflow area and to pass them in spill slots.
-copyInOflow  :: DynFlags -> Convention -> Area -> [CmmFormal]
+-- parameters on the stack, but sometimes we want to pass the
+-- variables in their spill slots.  Therefore, for copying arguments
+-- and results, we provide different functions to pass the arguments
+-- in an overflow area and to pass them in spill slots.
+copyInOflow  :: DynFlags -> Convention -> Area
+             -> [CmmFormal]
+             -> [CmmFormal]
              -> (Int, CmmAGraph)
 
-copyInOflow dflags conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
-  where (offset, nodes) = copyIn dflags oneCopyOflowI conv area formals
-
-type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
-                          (ByteOff, [CmmNode O O])
-type CopyIn  = DynFlags -> SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O])
+copyInOflow dflags conv area formals extra_stk
+  = (offset, catAGraphs $ map mkMiddle nodes)
+  where (offset, nodes) = copyIn dflags conv area formals extra_stk
 
 -- Return the number of bytes used for copying arguments, as well as the
 -- instructions to copy the arguments.
-copyIn :: CopyIn
-copyIn dflags oflow conv area formals =
-  foldr ci (init_offset, []) args'
-  where ci (reg, RegisterParam r) (n, ms) =
-          (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
-        ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
-        init_offset = widthInBytes (wordWidth dflags) -- infotable
-        args  = assignArgumentsPos dflags conv localRegType formals
-        args' = foldl adjust [] args
-          where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
-                adjust rst x@(_, RegisterParam _) = x : rst
-
--- Copy-in one arg, using overflow space if needed.
-oneCopyOflowI :: SlotCopier
-oneCopyOflowI area (reg, off) (n, ms) =
-  (max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms)
-  where ty = localRegType reg
+copyIn :: DynFlags -> Convention -> Area
+       -> [CmmFormal]
+       -> [CmmFormal]
+       -> (ByteOff, [CmmNode O O])
+copyIn dflags conv area formals extra_stk
+  = (stk_size, map ci (stk_args ++ args))
+  where
+     ci (reg, RegisterParam r) =
+          CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal r))
+     ci (reg, StackParam off) =
+          CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
+          where ty = localRegType reg
+
+     init_offset = widthInBytes (wordWidth dflags) -- infotable
+
+     (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk
+
+     (stk_size, args) = assignArgumentsPos dflags stk_off conv
+                                           localRegType formals
 
 -- Factoring out the common parts of the copyout functions yielded something
 -- more complicated:
@@ -323,7 +339,7 @@ data Transfer = Call | JumpRet | Jump | Ret deriving Eq
 
 copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual]
              -> UpdFrameOffset
-             -> (ByteOff, [(CmmExpr,ByteOff)]) -- extra stack stuff
+             -> [CmmActual] -- extra stack args
              -> (Int, [GlobalReg], CmmAGraph)
 
 -- Generate code to move the actual parameters into the locations
@@ -335,22 +351,20 @@ copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual]
 -- the info table for return and adjust the offsets of the other
 -- parameters.  If this is a call instruction, we adjust the offsets
 -- of the other parameters.
-copyOutOflow dflags conv transfer area actuals updfr_off
-  (extra_stack_off, extra_stack_stuff)
-  = foldr co (init_offset, [], mkNop) (args' ++ stack_params)
-  where 
-    co (v, RegisterParam r) (n, rs, ms)
-       = (n, r:rs, mkAssign (CmmGlobal r) v <*> ms)
-    co (v, StackParam off)  (n, rs, ms)
-       = (max n off, rs, mkStore (CmmStackSlot area off) v <*> ms)
-
-    stack_params = [ (e, StackParam (off + init_offset))
-                   | (e,off) <- extra_stack_stuff ]
+copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
+  = (stk_size, regs, graph)
+  where
+    (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
+
+    co (v, RegisterParam r) (rs, ms)
+       = (r:rs, mkAssign (CmmGlobal r) v <*> ms)
+    co (v, StackParam off)  (rs, ms)
+       = (rs, mkStore (CmmStackSlot area off) v <*> ms)
 
     (setRA, init_offset) =
       case area of
-            Young id -> id `seq` -- Generate a store instruction for
-                                 -- the return address if making a call
+            Young id ->  -- Generate a store instruction for
+                         -- the return address if making a call
                   case transfer of
                      Call ->
                        ([(CmmLit (CmmBlock id), StackParam init_offset)],
@@ -362,19 +376,19 @@ copyOutOflow dflags conv transfer area actuals updfr_off
                        ([], 0)
             Old -> ([], updfr_off)
 
-    arg_offset = init_offset + extra_stack_off
+    (extra_stack_off, stack_params) =
+       assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff
 
     args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it
-    args = assignArgumentsPos dflags conv (cmmExprType dflags) actuals
-
-    args' = foldl adjust setRA args
-      where adjust rst   (v, StackParam off)  = (v, StackParam (off + arg_offset)) : rst
-            adjust rst x@(_, RegisterParam _) = x : rst
+    (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
+                                          (cmmExprType dflags) actuals
 
 
 
-mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> (Int, CmmAGraph)
-mkCallEntry dflags conv formals = copyInOflow dflags conv Old formals
+mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
+            -> (Int, CmmAGraph)
+mkCallEntry dflags conv formals extra_stk
+  = copyInOflow dflags conv Old formals extra_stk
 
 lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual]
              -> UpdFrameOffset
@@ -386,7 +400,7 @@ lastWithArgs dflags transfer area conv actuals updfr_off last =
 
 lastWithArgsAndExtraStack :: DynFlags
              -> Transfer -> Area -> Convention -> [CmmActual]
-             -> UpdFrameOffset -> (ByteOff, [(CmmExpr,ByteOff)])
+             -> UpdFrameOffset -> [CmmActual]
              -> (ByteOff -> [GlobalReg] -> CmmAGraph)
              -> CmmAGraph
 lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
@@ -397,8 +411,8 @@ lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
                                updfr_off extra_stack
 
 
-noExtraStack :: (ByteOff, [(CmmExpr,ByteOff)])
-noExtraStack = (0,[])
+noExtraStack :: [CmmActual]
+noExtraStack = []
 
 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
        -> ByteOff -> [GlobalReg]
index 05aa5fb..3d0599b 100644 (file)
@@ -16,7 +16,7 @@ module OldCmm (
 
         GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
 
-        CmmStmt(..), CmmReturnInfo(..), CmmHinted(..),
+        CmmStmt(..), New.CmmReturnInfo(..), CmmHinted(..),
         HintedCmmFormal, HintedCmmActual,
 
         CmmSafety(..), CmmCallTarget(..),
@@ -120,11 +120,6 @@ cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g'
 cmmTopMapGraph f (CmmProc h l g) = CmmProc h l (f g)
 cmmTopMapGraph _ (CmmData s ds)  = CmmData s ds
 
-data CmmReturnInfo
-  = CmmMayReturn
-  | CmmNeverReturns
-  deriving ( Eq )
-
 -----------------------------------------------------------------------------
 --              CmmStmt
 -- A "statement".  Note that all branches are explicit: there are no
@@ -145,7 +140,7 @@ data CmmStmt
       CmmCallTarget
       [HintedCmmFormal]            -- zero or more results
       [HintedCmmActual]            -- zero or more arguments
-      CmmReturnInfo
+      New.CmmReturnInfo
       -- Some care is necessary when handling the arguments of these, see
       -- [Register parameter passing] and the hack in cmm/CmmOpt.hs
 
index a3857d4..dcde86e 100644 (file)
@@ -111,12 +111,8 @@ pprStmt stmt = case stmt of
           pp_lhs | null results = empty
                  | otherwise    = commafy (map ppr_ar results) <+> equals
                 -- Don't print the hints on a native C-- call
-          ppr_ar (CmmHinted ar k) = case cconv of
-                            CmmCallConv -> ppr ar
-                            _           -> ppr (ar,k)
-          pp_conv = case cconv of
-                      CmmCallConv -> empty
-                      _           -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
+          ppr_ar (CmmHinted ar k) = ppr (ar,k)
+          pp_conv = ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
 
     -- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
     CmmCall (CmmPrim op _) results args ret ->
index 1a3eb0d..a2427df 100644 (file)
@@ -865,7 +865,6 @@ is_cishCC :: CCallConv -> Bool
 is_cishCC CCallConv    = True
 is_cishCC CApiConv     = True
 is_cishCC StdCallConv  = True
-is_cishCC CmmCallConv  = False
 is_cishCC PrimCallConv = False
 
 -- ---------------------------------------------------------------------
index 423bcd5..f3e2a02 100644 (file)
@@ -75,6 +75,8 @@ instance Outputable ForeignConvention where
 instance Outputable ForeignTarget where
     ppr = pprForeignTarget
 
+instance Outputable CmmReturnInfo where
+    ppr = pprReturnInfo
 
 instance Outputable (Block CmmNode C C) where
     ppr = pprBlock
@@ -145,17 +147,18 @@ pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
 pprConvention (NativeReturn {})     = text "<native-ret-convention>"
 pprConvention  Slow                 = text "<slow-convention>"
 pprConvention  GC                   = text "<gc-convention>"
-pprConvention  PrimOpCall           = text "<primop-call-convention>"
-pprConvention  PrimOpReturn         = text "<primop-ret-convention>"
 
 pprForeignConvention :: ForeignConvention -> SDoc
-pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
+pprForeignConvention (ForeignConvention c args res ret) =
+          doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
+
+pprReturnInfo :: CmmReturnInfo -> SDoc
+pprReturnInfo CmmMayReturn = empty
+pprReturnInfo CmmNeverReturns = ptext (sLit "never returns")
 
 pprForeignTarget :: ForeignTarget -> SDoc
-pprForeignTarget (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
-  where ppr_fc :: ForeignConvention -> SDoc
-        ppr_fc (ForeignConvention c args res) =
-          doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res
+pprForeignTarget (ForeignTarget fn c) = ppr c <+> ppr_target fn
+  where
         ppr_target :: CmmExpr -> SDoc
         ppr_target t@(CmmLit _) = ppr t
         ppr_target fn'          = parens (ppr fn')
index d964448..ac021df 100644 (file)
@@ -30,6 +30,7 @@ module SMRep (
 
         -- ** Predicates
         isStaticRep, isConRep, isThunkRep, isFunRep, isStaticNoCafCon,
+        isStackRep,
 
         -- ** Size-related things
         heapClosureSize,
@@ -148,7 +149,7 @@ data SMRep
         Liveness
 
   | RTSRep              -- The RTS needs to declare info tables with specific
-        StgHalfWord     -- type tags, so this form lets us override the default
+        Int             -- type tags, so this form lets us override the default
         SMRep           -- tag for an SMRep.
 
 -- | True <=> This is a static closure.  Affects how we garbage-collect it.
@@ -166,10 +167,10 @@ data ClosureTypeInfo
   | ThunkSelector SelectorOffset
   | BlackHole
 
-type ConstrTag         = StgHalfWord
+type ConstrTag         = Int
 type ConstrDescription = [Word8] -- result of dataConIdentity
-type FunArity          = StgHalfWord
-type SelectorOffset    = StgWord
+type FunArity          = Int
+type SelectorOffset    = Int
 
 -------------------------
 -- We represent liveness bitmaps as a Bitmap (whose internal
@@ -188,7 +189,7 @@ type Liveness = [Bool]   -- One Bool per word; True  <=> non-ptr or dead
 
 data ArgDescr
   = ArgSpec             -- Fits one of the standard patterns
-        !StgHalfWord    -- RTS type identifier ARG_P, ARG_N, ...
+        !Int            -- RTS type identifier ARG_P, ARG_N, ...
 
   | ArgGen              -- General case
         Liveness        -- Details about the arguments
@@ -212,7 +213,7 @@ mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type_info
      hdr_size     = closureTypeHdrSize dflags cl_type_info
      payload_size = ptr_wds + nonptr_wds
 
-mkRTSRep :: StgHalfWord -> SMRep -> SMRep
+mkRTSRep :: Int -> SMRep -> SMRep
 mkRTSRep = RTSRep
 
 mkStackRep :: [Bool] -> SMRep
@@ -229,6 +230,11 @@ isStaticRep (HeapRep is_static _ _ _) = is_static
 isStaticRep (StackRep {})             = False
 isStaticRep (RTSRep _ rep)            = isStaticRep rep
 
+isStackRep :: SMRep -> Bool
+isStackRep StackRep{}     = True
+isStackRep (RTSRep _ rep) = isStackRep rep
+isStackRep _              = False
+
 isConRep :: SMRep -> Bool
 isConRep (HeapRep _ _ _ Constr{}) = True
 isConRep _                        = False
@@ -314,11 +320,10 @@ closureTypeHdrSize dflags ty = case ty of
 -- Defines CONSTR, CONSTR_1_0 etc
 
 -- | Derives the RTS closure type from an 'SMRep'
-rtsClosureType :: DynFlags -> SMRep -> StgHalfWord
-rtsClosureType dflags rep
-    = toStgHalfWord dflags
-    $ case rep of
-      RTSRep ty _ -> fromStgHalfWord ty
+rtsClosureType :: SMRep -> Int
+rtsClosureType rep
+    = case rep of
+      RTSRep ty _ -> ty
 
       HeapRep False 1 0 Constr{} -> CONSTR_1_0
       HeapRep False 0 1 Constr{} -> CONSTR_0_1
@@ -355,11 +360,11 @@ rtsClosureType dflags rep
       _ -> panic "rtsClosureType"
 
 -- We export these ones
-rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: DynFlags -> StgHalfWord
-rET_SMALL   dflags = toStgHalfWord dflags RET_SMALL
-rET_BIG     dflags = toStgHalfWord dflags RET_BIG
-aRG_GEN     dflags = toStgHalfWord dflags ARG_GEN
-aRG_GEN_BIG dflags = toStgHalfWord dflags ARG_GEN_BIG
+rET_SMALL, rET_BIG, aRG_GEN, aRG_GEN_BIG :: Int
+rET_SMALL   = RET_SMALL
+rET_BIG     = RET_BIG
+aRG_GEN     = ARG_GEN
+aRG_GEN_BIG = ARG_GEN_BIG
 \end{code}
 
 Note [Static NoCaf constructors]
index 1f5b711..d548741 100644 (file)
@@ -70,7 +70,7 @@ mkArgDescr _nm args
        let arg_bits = argBits dflags arg_reps
            arg_reps = filter nonVoidArg (map idCgRep args)
            -- Getting rid of voids eases matching of standard patterns
-       case stdPattern dflags arg_reps of
+       case stdPattern arg_reps of
            Just spec_id -> return (ArgSpec spec_id)
            Nothing      -> return (ArgGen arg_bits)
 
@@ -79,10 +79,9 @@ argBits _      []              = []
 argBits dflags (PtrArg : args) = False : argBits dflags args
 argBits dflags (arg    : args) = take (cgRepSizeW dflags arg) (repeat True) ++ argBits dflags args
 
-stdPattern :: DynFlags -> [CgRep] -> Maybe StgHalfWord
-stdPattern dflags reps
-    = fmap (toStgHalfWord dflags)
-    $ case reps of
+stdPattern :: [CgRep] -> Maybe Int
+stdPattern reps
+    = case reps of
       []          -> Just ARG_NONE  -- just void args, probably
 
       [PtrArg]    -> Just ARG_P
index aeb8723..858de3a 100644 (file)
@@ -189,7 +189,7 @@ buildDynCon' dflags platform binder _ con [arg_amode]
   , (_, CmmLit (CmmInt val _)) <- arg_amode
   , let val_int = (fromIntegral val) :: Int
   , val_int <= mAX_INTLIKE dflags && val_int >= mIN_INTLIKE dflags
-  = do  { let intlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure")
+  = do  { let intlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE")
               offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1)
                 -- INTLIKE closures consist of a header and one word payload
               intlike_amode = CmmLit (cmmLabelOffW dflags intlike_lbl offsetW)
@@ -201,7 +201,7 @@ buildDynCon' dflags platform binder _ con [arg_amode]
   , (_, CmmLit (CmmInt val _)) <- arg_amode
   , let val_int = (fromIntegral val) :: Int
   , val_int <= mAX_CHARLIKE dflags && val_int >= mIN_CHARLIKE dflags
-  = do  { let charlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure")
+  = do  { let charlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE")
               offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1)
                 -- CHARLIKE closures consist of a header and one word payload
               charlike_amode = CmmLit (cmmLabelOffW dflags charlike_lbl offsetW)
index 965abf0..8cff773 100644 (file)
@@ -415,7 +415,7 @@ unbxTupleHeapCheck regs ptrs nptrs fail_code code
         { dflags <- getDynFlags
         ; let full_fail_code  = fail_code `plusStmts` oneStmt assign_liveness
               assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9 VNonGcPtr))    -- Ho ho ho!
-                                          (CmmLit (mkWordCLit dflags liveness))
+                                          (CmmLit (mkStgWordCLit dflags liveness))
               liveness        = mkRegLiveness dflags regs ptrs nptrs
               live            = Just $ map snd regs
               rts_label       = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_ut")))
index c124b5f..03e01b3 100644 (file)
@@ -258,7 +258,7 @@ dynLdvInit :: DynFlags -> CmmExpr
 dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE
   CmmMachOp (mo_wordOr dflags) [
       CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],
-      CmmLit (mkWordCLit dflags (lDV_STATE_CREATE dflags))
+      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))
   ]
 
 --
@@ -289,8 +289,8 @@ ldvEnter cl_ptr = do
         -- don't forget to substract node's tag
     ldv_wd = ldvWord dflags cl_ptr
     new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
-                                                     (CmmLit (mkWordCLit dflags (lDV_CREATE_MASK dflags))))
-                 (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (lDV_STATE_USE dflags))))
+                                                     (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))
+                 (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))
   ifProfiling $
      -- if (era > 0) {
      --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
@@ -308,10 +308,3 @@ ldvWord :: DynFlags -> CmmExpr -> CmmExpr
 ldvWord dflags closure_ptr
     = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
 
-lDV_CREATE_MASK :: DynFlags -> StgWord
-lDV_CREATE_MASK dflags = toStgWord dflags (iLDV_CREATE_MASK dflags)
-lDV_STATE_CREATE :: DynFlags -> StgWord
-lDV_STATE_CREATE dflags = toStgWord dflags (iLDV_STATE_CREATE dflags)
-lDV_STATE_USE :: DynFlags -> StgWord
-lDV_STATE_USE dflags = toStgWord dflags (iLDV_STATE_USE dflags)
-
index 3a106ab..9f9a2cf 100644 (file)
@@ -800,8 +800,8 @@ getSRTInfo = do
             let srt_desc_lbl = mkLargeSRTLabel id
             emitRODataLits "getSRTInfo" srt_desc_lbl
              ( cmmLabelOffW dflags srt_lbl off
-               : mkWordCLit dflags (toStgWord dflags (toInteger len))
-               : map (mkWordCLit dflags) bmp)
+               : mkWordCLit dflags (toInteger len)
+               : map (mkWordCLit dflags . fromStgWord) bmp)
             return (C_SRT srt_desc_lbl 0 (srt_escape dflags))
 
       | otherwise
index 740bfab..f2cbc21 100644 (file)
@@ -480,7 +480,7 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds srt_info descr
                    -- anything else gets eta expanded.
   where
     name   = idName id
-    sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info)
+    sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
     nonptr_wds = tot_wds - ptr_wds
 
 mkConInfo :: DynFlags
@@ -492,7 +492,7 @@ mkConInfo dflags is_static data_con tot_wds ptr_wds
    = ConInfo { closureSMRep = sm_rep,
                closureCon = data_con }
   where
-    sm_rep  = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info)
+    sm_rep  = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
     lf_info = mkConLFInfo data_con
     nonptr_wds = tot_wds - ptr_wds
 \end{code}
@@ -526,16 +526,16 @@ closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
 %************************************************************************
 
 \begin{code}
-lfClosureType :: DynFlags -> LambdaFormInfo -> ClosureTypeInfo
-lfClosureType dflags (LFReEntrant _ arity _ argd) = Fun (toStgHalfWord dflags (toInteger arity)) argd
-lfClosureType dflags (LFCon con)                  = Constr (toStgHalfWord dflags (toInteger (dataConTagZ con)))
-                                                           (dataConIdentity con)
-lfClosureType dflags (LFThunk _ _ _ is_sel _)     = thunkClosureType dflags is_sel
-lfClosureType _      _                            = panic "lfClosureType"
-
-thunkClosureType :: DynFlags -> StandardFormInfo -> ClosureTypeInfo
-thunkClosureType dflags (SelectorThunk off) = ThunkSelector (toStgWord dflags (toInteger off))
-thunkClosureType _      _                   = Thunk
+lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
+lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd
+lfClosureType (LFCon con)                  = Constr (dataConTagZ con)
+                                                    (dataConIdentity con)
+lfClosureType (LFThunk _ _ _ is_sel _)     = thunkClosureType is_sel
+lfClosureType _                            = panic "lfClosureType"
+
+thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
+thunkClosureType (SelectorThunk off) = ThunkSelector off
+thunkClosureType _                   = Thunk
 
 -- We *do* get non-updatable top-level thunks sometimes.  eg. f = g
 -- gets compiled to a jump to g (if g has non-zero arity), instead of
index 37ca5e0..67aae3f 100644 (file)
@@ -245,7 +245,7 @@ cgDataCon data_con
             arg_reps = [(typePrimRep rep_ty, rep_ty) | ty <- dataConRepArgTys data_con, rep_ty <- flattenRepType (repType ty)]
 
             -- Dynamic closure code for non-nullary constructors only
-        ; whenC (not (isNullaryRepDataCon data_con))
+        ; when (not (isNullaryRepDataCon data_con))
                 (emit_info dyn_info_tbl tickyEnterDynCon)
 
                 -- Dynamic-Closure first, to reduce forward references
index 89d27dd..5e46dcf 100644 (file)
@@ -10,7 +10,7 @@ module StgCmmBind (
         cgTopRhsClosure,
         cgBind,
         emitBlackHoleCode,
-        pushUpdateFrame
+        pushUpdateFrame, emitUpdateFrame
   ) where
 
 #include "HsVersions.h"
@@ -37,7 +37,6 @@ import CLabel
 import StgSyn
 import CostCentre
 import Id
-import Control.Monad
 import Name
 import Module
 import ListSetOps
@@ -48,6 +47,8 @@ import FastString
 import Maybes
 import DynFlags
 
+import Control.Monad
+
 ------------------------------------------------------------------------
 --              Top-level bindings
 ------------------------------------------------------------------------
@@ -460,7 +461,7 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
                     (CmmMachOp (mo_wordSub dflags)
                          [ CmmReg nodeReg
                          , mkIntExpr dflags (funTag dflags cl_info) ])
-                ; whenC node_points (ldvEnterClosure cl_info)
+                ; when node_points (ldvEnterClosure cl_info)
                 ; granYield arg_regs node_points
 
                 -- Main payload
@@ -525,8 +526,8 @@ thunkCode cl_info fv_details _cc node arity body
         ; entryHeapCheck cl_info node' arity [] $ do
         { -- Overwrite with black hole if necessary
           -- but *after* the heap-overflow check
-        ; whenC (blackHoleOnEntry cl_info && node_points)
-                (blackHoleIt cl_info)
+        ; when (blackHoleOnEntry cl_info && node_points)
+                (blackHoleIt cl_info node)
 
           -- Push update frame
         ; setupUpdate cl_info node $
@@ -545,13 +546,14 @@ thunkCode cl_info fv_details _cc node arity body
 --              Update and black-hole wrappers
 ------------------------------------------------------------------------
 
-blackHoleIt :: ClosureInfo -> FCode ()
+blackHoleIt :: ClosureInfo -> LocalReg -> FCode ()
 -- Only called for closures with no args
 -- Node points to the closure
-blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
+blackHoleIt closure_info node
+  = emitBlackHoleCode (closureSingleEntry closure_info) (CmmReg (CmmLocal node))
 
-emitBlackHoleCode :: Bool -> FCode ()
-emitBlackHoleCode is_single_entry = do
+emitBlackHoleCode :: Bool -> CmmExpr -> FCode ()
+emitBlackHoleCode is_single_entry node = do
   dflags <- getDynFlags
 
   -- Eager blackholing is normally disabled, but can be turned on with
@@ -578,12 +580,12 @@ emitBlackHoleCode is_single_entry = do
              -- profiling), so currently eager blackholing doesn't
              -- work with profiling.
 
-  whenC eager_blackholing $ do
+  when eager_blackholing $ do
     tickyBlackHole (not is_single_entry)
-    emitStore (cmmOffsetW dflags (CmmReg nodeReg) (fixedHdrSize dflags))
+    emitStore (cmmOffsetW dflags node (fixedHdrSize dflags))
                   (CmmReg (CmmGlobal CurrentTSO))
     emitPrimCall [] MO_WriteBarrier []
-    emitStore (CmmReg nodeReg) (CmmReg (CmmGlobal EagerBlackholeInfo))
+    emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
 
 setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
         -- Nota Bene: this function does not change Node (even if it's a CAF),
@@ -634,13 +636,20 @@ pushUpdateFrame lbl updatee body
        let
            hdr         = fixedHdrSize dflags * wORD_SIZE dflags
            frame       = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags
-           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags
        --
-       emitStore (CmmStackSlot Old frame) (mkLblExpr lbl)
-       emitStore (CmmStackSlot Old (frame - off_updatee)) updatee
-       initUpdFrameProf frame
+       emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee
        withUpdFrameOff frame body
 
+emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()
+emitUpdateFrame dflags frame lbl updatee = do
+  let
+           hdr         = fixedHdrSize dflags * wORD_SIZE dflags
+           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags
+  --
+  emitStore frame (mkLblExpr lbl)
+  emitStore (cmmOffset dflags frame off_updatee) updatee
+  initUpdFrameProf frame
+
 -----------------------------------------------------------------------------
 -- Entering a CAF
 --
index 4be5bd3..f865c37 100644 (file)
@@ -353,16 +353,16 @@ isLFReEntrant _                = False
 --             Choosing SM reps
 -----------------------------------------------------------------------------
 
-lfClosureType :: DynFlags -> LambdaFormInfo -> ClosureTypeInfo
-lfClosureType dflags (LFReEntrant _ arity _ argd) = Fun (toStgHalfWord dflags (toInteger arity)) argd
-lfClosureType dflags (LFCon con)                  = Constr (toStgHalfWord dflags (toInteger (dataConTagZ con)))
-                                                           (dataConIdentity con)
-lfClosureType dflags (LFThunk _ _ _ is_sel _)     = thunkClosureType dflags is_sel
-lfClosureType _      _                            = panic "lfClosureType"
+lfClosureType :: LambdaFormInfo -> ClosureTypeInfo
+lfClosureType (LFReEntrant _ arity _ argd) = Fun arity argd
+lfClosureType (LFCon con)                  = Constr (dataConTagZ con)
+                                                    (dataConIdentity con)
+lfClosureType (LFThunk _ _ _ is_sel _)     = thunkClosureType is_sel
+lfClosureType _                            = panic "lfClosureType"
 
-thunkClosureType :: DynFlags -> StandardFormInfo -> ClosureTypeInfo
-thunkClosureType dflags (SelectorThunk off) = ThunkSelector (toStgWord dflags (toInteger off))
-thunkClosureType _      _                   = Thunk
+thunkClosureType :: StandardFormInfo -> ClosureTypeInfo
+thunkClosureType (SelectorThunk off) = ThunkSelector off
+thunkClosureType _                   = Thunk
 
 -- We *do* get non-updatable top-level thunks sometimes.  eg. f = g
 -- gets compiled to a jump to g (if g has non-zero arity), instead of
@@ -373,8 +373,6 @@ thunkClosureType _      _                   = Thunk
 --             nodeMustPointToIt
 -----------------------------------------------------------------------------
 
--- Be sure to see the stg-details notes about these...
-
 nodeMustPointToIt :: DynFlags -> LambdaFormInfo -> Bool
 nodeMustPointToIt _ (LFReEntrant top _ no_fvs _)
   = not no_fvs ||   -- Certainly if it has fvs we need to point to it
@@ -687,7 +685,7 @@ mkClosureInfo dflags is_static id lf_info tot_wds ptr_wds val_descr
                   closureProf      = prof }     -- (we don't have an SRT yet)
   where
     name       = idName id
-    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType dflags lf_info)
+    sm_rep     = mkHeapRep dflags is_static ptr_wds nonptr_wds (lfClosureType lf_info)
     prof       = mkProfilingInfo dflags id val_descr
     nonptr_wds = tot_wds - ptr_wds
 
@@ -899,8 +897,7 @@ mkDataConInfoTable dflags data_con is_static ptr_wds nonptr_wds
 
    sm_rep = mkHeapRep dflags is_static ptr_wds nonptr_wds cl_type
 
-   cl_type = Constr (toStgHalfWord dflags (toInteger (dataConTagZ data_con)))
-                    (dataConIdentity data_con)
+   cl_type = Constr (dataConTagZ data_con) (dataConIdentity data_con)
 
    prof | not (dopt Opt_SccProfilingOn dflags) = NoProfilingInfo
         | otherwise                            = ProfilingInfo ty_descr val_descr
index c822a64..8e775de 100644 (file)
@@ -185,7 +185,7 @@ buildDynCon' dflags platform binder _cc con [arg]
   , StgLitArg (MachInt val) <- arg
   , val <= fromIntegral (mAX_INTLIKE dflags) -- Comparisons at type Integer!
   , val >= fromIntegral (mIN_INTLIKE dflags) -- ...ditto...
-  = do  { let intlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure")
+  = do  { let intlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_INTLIKE")
               val_int = fromIntegral val :: Int
               offsetW = (val_int - mIN_INTLIKE dflags) * (fixedHdrSize dflags + 1)
                 -- INTLIKE closures consist of a header and one word payload
@@ -200,7 +200,7 @@ buildDynCon' dflags platform binder _cc con [arg]
   , let val_int = ord val :: Int
   , val_int <= mAX_CHARLIKE dflags
   , val_int >= mIN_CHARLIKE dflags
-  = do  { let charlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure")
+  = do  { let charlike_lbl   = mkCmmClosureLabel rtsPackageId (fsLit "stg_CHARLIKE")
               offsetW = (val_int - mIN_CHARLIKE dflags) * (fixedHdrSize dflags + 1)
                 -- CHARLIKE closures consist of a header and one word payload
               charlike_amode = cmmLabelOffW dflags charlike_lbl offsetW
index a8ffc12..a085925 100644 (file)
@@ -717,12 +717,12 @@ emitEnter fun = do
       --
       AssignTo res_regs _ -> do
        { lret <- newLabelC
-       ; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs
+       ; let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) res_regs []
        ; lcall <- newLabelC
        ; updfr_off <- getUpdFrameOff
        ; let area = Young lret
        ; let (outArgs, regs, copyout) = copyOutOflow dflags NativeNodeCall Call area
-                                          [fun] updfr_off (0,[])
+                                          [fun] updfr_off []
          -- refer to fun via nodeReg after the copyout, to avoid having
          -- both live simultaneously; this sometimes enables fun to be
          -- inlined in the RHS of the R1 assignment.
similarity index 66%
rename from compiler/codeGen/CgExtCode.hs
rename to compiler/codeGen/StgCmmExtCode.hs
index a651319..b060822 100644 (file)
@@ -9,44 +9,36 @@
 -- to collect declarations as we parse the proc, and feed the environment
 -- back in circularly (to avoid a two-pass algorithm).
 
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module CgExtCode (
-       ExtFCode(..),
-       ExtCode,
-       Named(..), Env,
+module StgCmmExtCode (
+       CmmParse(..),
+        Named(..), Env,
        
        loopDecls,
        getEnv,
 
        newLocal,
-       newLabel,
+        newLabel,
+        newBlockId,
        newFunctionName,
        newImport,
        lookupLabel,
        lookupName,
 
        code,
-       code2,
-       nopEC,
-       stmtEC,
-       stmtsEC,
-       getCgStmtsEC,
-       getCgStmtsEC',
-       forkLabelledCodeEC
+        emit, emitLabel, emitAssign, emitStore,
+        getCode, getCodeR,
+        emitOutOfLine,
+        withUpdFrameOff, getUpdFrameOff
 )
 
 where
 
-import CgMonad
+import qualified StgCmmMonad as F
+import StgCmmMonad (FCode, newUnique)
 
+import Cmm
 import CLabel
-import OldCmm hiding( ClosureTypeInfo(..) )
+import MkGraph
 
 -- import BasicTypes
 import BlockId
@@ -73,22 +65,22 @@ type Decls  = [(FastString,Named)]
 
 -- | Does a computation in the FCode monad, with a current environment
 --     and a list of local declarations. Returns the resulting list of declarations.
-newtype ExtFCode a     
+newtype CmmParse a     
        = EC { unEC :: Env -> Decls -> FCode (Decls, a) }
 
-type ExtCode = ExtFCode ()
+type ExtCode = CmmParse ()
 
-returnExtFC :: a -> ExtFCode a
+returnExtFC :: a -> CmmParse a
 returnExtFC a  = EC $ \_ s -> return (s, a)
 
-thenExtFC :: ExtFCode a -> (a -> ExtFCode b) -> ExtFCode b
+thenExtFC :: CmmParse a -> (a -> CmmParse b) -> CmmParse b
 thenExtFC (EC m) k = EC $ \e s -> do (s',r) <- m e s; unEC (k r) e s'
 
-instance Monad ExtFCode where
+instance Monad CmmParse where
   (>>=) = thenExtFC
   return = returnExtFC
 
-instance HasDynFlags ExtFCode where
+instance HasDynFlags CmmParse where
     getDynFlags = EC (\_ d -> do dflags <- getDynFlags
                                  return (d, dflags))
 
@@ -99,15 +91,15 @@ instance HasDynFlags ExtFCode where
 --     procedure, and imports that scope over the entire module.
 --     Discards the local declaration contained within decl'
 --
-loopDecls :: ExtFCode a -> ExtFCode a
+loopDecls :: CmmParse a -> CmmParse a
 loopDecls (EC fcode) =
       EC $ \e globalDecls -> do
-       (_, a) <- fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
+        (_, a) <- F.fixC (\ ~(decls, _) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
        return (globalDecls, a)
 
 
 -- | Get the current environment from the monad.
-getEnv :: ExtFCode Env
+getEnv :: CmmParse Env
 getEnv         = EC $ \e s -> return (s, e)
 
 
@@ -127,7 +119,7 @@ addLabel name block_id
 newLocal 
        :: CmmType              -- ^ data type
        -> FastString           -- ^ name of variable
-       -> ExtFCode LocalReg    -- ^ register holding the value
+       -> CmmParse LocalReg    -- ^ register holding the value
        
 newLocal ty name = do
    u <- code newUnique
@@ -137,12 +129,14 @@ newLocal ty name = do
 
 
 -- | Allocate a fresh label.
-newLabel :: FastString -> ExtFCode BlockId
+newLabel :: FastString -> CmmParse BlockId
 newLabel name = do
    u <- code newUnique
    addLabel name (mkBlockId u)
    return (mkBlockId u)
 
+newBlockId :: CmmParse BlockId
+newBlockId = code F.newLabelC
 
 -- | Add add a local function to the environment.
 newFunctionName 
@@ -159,7 +153,7 @@ newFunctionName name pkg
 --     over the whole module.
 newImport 
        :: (FastString, CLabel) 
-       -> ExtFCode ()
+       -> CmmParse ()
 
 newImport (name, cmmLabel) 
    = addVarDecl name (CmmLit (CmmLabel cmmLabel))
@@ -168,7 +162,7 @@ newImport (name, cmmLabel)
 -- | Lookup the BlockId bound to the label with this name.
 --     If one hasn't been bound yet, create a fresh one based on the 
 --     Unique of the name.
-lookupLabel :: FastString -> ExtFCode BlockId
+lookupLabel :: FastString -> CmmParse BlockId
 lookupLabel name = do
   env <- getEnv
   return $ 
@@ -181,7 +175,7 @@ lookupLabel name = do
 --     Unknown names are treated as if they had been 'import'ed from the runtime system.
 --     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 :: FastString -> CmmParse CmmExpr
 lookupName name = do
   env    <- getEnv
   return $ 
@@ -191,51 +185,40 @@ lookupName name = do
        _other          -> CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId name))
 
 
--- | Lift an FCode computation into the ExtFCode monad
-code :: FCode a -> ExtFCode a
+-- | Lift an FCode computation into the CmmParse monad
+code :: FCode a -> CmmParse a
 code fc = EC $ \_ s -> do 
                r <- fc
                return (s, r)
 
+emit :: CmmAGraph -> CmmParse ()
+emit = code . F.emit
 
-code2 :: (FCode (Decls,b) -> FCode ((Decls,b),c)) -> ExtFCode b -> ExtFCode c
-code2 f (EC ec) 
-       = EC $ \e s -> do 
-               ((s', _),c) <- f (ec e s)
-               return (s',c)
+emitLabel :: BlockId -> CmmParse ()
+emitLabel = code. F.emitLabel
 
+emitAssign :: CmmReg  -> CmmExpr -> CmmParse ()
+emitAssign l r = code (F.emitAssign l r)
 
--- | Do nothing in the ExtFCode monad.
-nopEC :: ExtFCode ()
-nopEC = code nopC
+emitStore :: CmmExpr  -> CmmExpr -> CmmParse ()
+emitStore l r = code (F.emitStore l r)
 
+getCode :: CmmParse a -> CmmParse CmmAGraph
+getCode (EC ec) = EC $ \e s -> do
+  ((s',_), gr) <- F.getCodeR (ec e s)
+  return (s', gr)
 
--- | Accumulate a CmmStmt into the monad state.
-stmtEC :: CmmStmt -> ExtFCode () 
-stmtEC stmt = code (stmtC stmt)
+getCodeR :: CmmParse a -> CmmParse (a, CmmAGraph)
+getCodeR (EC ec) = EC $ \e s -> do
+  ((s', r), gr) <- F.getCodeR (ec e s)
+  return (s', (r,gr))
 
+emitOutOfLine :: BlockId -> CmmAGraph -> CmmParse ()
+emitOutOfLine l g = code (F.emitOutOfLine l g)
 
--- | Accumulate some CmmStmts into the monad state.
-stmtsEC :: [CmmStmt] -> ExtFCode ()
-stmtsEC stmts = code (stmtsC stmts)
-
-
--- | Get the generated statements out of the monad state.
-getCgStmtsEC :: ExtFCode a -> ExtFCode CgStmts
-getCgStmtsEC = code2 getCgStmts'
-
-
--- | Get the generated statements, and the return value out of the monad state.
-getCgStmtsEC' :: ExtFCode a -> ExtFCode (a, CgStmts)
-getCgStmtsEC' = code2 (\m -> getCgStmts' m >>= f)
-  where f ((decl, b), c) = return ((decl, b), (b, c))
-
-
--- | Emit a chunk of code outside the instruction stream, 
---     and return its block id. 
-forkLabelledCodeEC :: ExtFCode a -> ExtFCode BlockId
-forkLabelledCodeEC ec = do
-  stmts <- getCgStmtsEC ec
-  code (forkCgStmts stmts)
-
+withUpdFrameOff :: UpdFrameOffset -> CmmParse () -> CmmParse ()
+withUpdFrameOff size inner
+  = EC $ \e s -> F.withUpdFrameOff size $ (unEC inner) e s
 
+getUpdFrameOff :: CmmParse UpdFrameOffset
+getUpdFrameOff = code $ F.getUpdFrameOff
index 9e4db9c..1830f7b 100644 (file)
@@ -9,9 +9,10 @@
 module StgCmmForeign (
   cgForeignCall, loadThreadState, saveThreadState,
   emitPrimCall, emitCCall,
+  emitForeignCall,     -- For CmmParse
   emitSaveThreadState, -- will be needed by the Cmm parser
   emitLoadThreadState, -- ditto
-  emitOpenNursery,
+  emitCloseNursery, emitOpenNursery
  ) where
 
 #include "HsVersions.h"
@@ -24,10 +25,8 @@ import StgCmmUtils
 import StgCmmClosure
 import StgCmmLayout
 
-import BlockId
 import Cmm
 import CmmUtils
-import OldCmm ( CmmReturnInfo(..) )
 import MkGraph
 import Type
 import TysPrim
@@ -85,7 +84,7 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
                    DynamicTarget    ->  case cmm_args of
                                            (fn,_):rest -> (unzip rest, fn)
                                            [] -> panic "cgForeignCall []"
-              fc = ForeignConvention cconv arg_hints res_hints
+              fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn
               call_target = ForeignTarget cmm_target fc
 
         -- we want to emit code for the call, and then emitReturn.
@@ -100,12 +99,10 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
         ; sequel <- getSequel
         ; case sequel of
             AssignTo assign_to_these _ ->
-                emitForeignCall safety assign_to_these call_target
-                                     call_args CmmMayReturn
+                emitForeignCall safety assign_to_these call_target call_args
 
             _something_else ->
-                do { _ <- emitForeignCall safety res_regs call_target
-                                     call_args CmmMayReturn
+                do { _ <- emitForeignCall safety res_regs call_target call_args
                    ; emitReturn (map (CmmReg . CmmLocal) res_regs)
                    }
          }
@@ -183,17 +180,17 @@ emitCCall :: [(CmmFormal,ForeignHint)]
           -> [(CmmActual,ForeignHint)]
           -> FCode ()
 emitCCall hinted_results fn hinted_args
-  = void $ emitForeignCall PlayRisky results target args CmmMayReturn
+  = void $ emitForeignCall PlayRisky results target args
   where
     (args, arg_hints) = unzip hinted_args
     (results, result_hints) = unzip hinted_results
     target = ForeignTarget fn fc
-    fc = ForeignConvention CCallConv arg_hints result_hints
+    fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn
 
 
 emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
 emitPrimCall res op args
-  = void $ emitForeignCall PlayRisky res (PrimTarget op) args CmmMayReturn
+  = void $ emitForeignCall PlayRisky res (PrimTarget op) args
 
 -- alternative entry point, used by CmmParse
 emitForeignCall
@@ -201,10 +198,8 @@ emitForeignCall
         -> [CmmFormal]          -- where to put the results
         -> ForeignTarget        -- the op
         -> [CmmActual]          -- arguments
-        -> CmmReturnInfo        -- This can say "never returns"
-                                --   only RTS procedures do this
         -> FCode ReturnKind
-emitForeignCall safety results target args _ret
+emitForeignCall safety results target args
   | not (playSafe safety) = do
     dflags <- getDynFlags
     let (caller_save, caller_load) = callerSaveVolatileRegs dflags
@@ -218,7 +213,7 @@ emitForeignCall safety results target args _ret
     updfr_off <- getUpdFrameOff
     temp_target <- load_target_into_temp target
     k <- newLabelC
-    let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results
+    let (off, copyout) = copyInOflow dflags NativeReturn (Young k) results []
        -- see Note [safe foreign call convention]
     emit $
            (    mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth dflags)))
@@ -285,17 +280,15 @@ saveThreadState dflags =
         mkStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS
       else mkNop
 
-emitSaveThreadState :: BlockId -> FCode ()
-emitSaveThreadState bid = do
+emitSaveThreadState :: FCode ()
+emitSaveThreadState = do
   dflags <- getDynFlags
+  emit (saveThreadState dflags)
 
-  -- CurrentTSO->stackobj->sp = Sp;
-  emitStore (cmmOffset dflags (CmmLoad (cmmOffset dflags stgCurrentTSO (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags))
-                 (CmmStackSlot (Young bid) (widthInBytes (typeWidth (gcWord dflags))))
-  emit $ closeNursery dflags
-  -- and save the current cost centre stack in the TSO when profiling:
-  when (dopt Opt_SccProfilingOn dflags) $
-        emitStore (cmmOffset dflags stgCurrentTSO (tso_CCCS dflags)) curCCS
+emitCloseNursery :: FCode ()
+emitCloseNursery = do
+  df <- getDynFlags
+  emit (closeNursery df)
 
    -- CurrentNursery->free = Hp+1;
 closeNursery :: DynFlags -> CmmAGraph
@@ -303,8 +296,6 @@ closeNursery dflags = mkStore (nursery_bdescr_free dflags) (cmmOffsetW dflags st
 
 loadThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
 loadThreadState dflags tso stack = do
-  -- tso <- newTemp (gcWord dflags) -- TODO FIXME NOW
-  -- stack <- newTemp (gcWord dflags) -- TODO FIXME NOW
   catAGraphs [
         -- tso = CurrentTSO;
         mkAssign (CmmLocal tso) stgCurrentTSO,
@@ -321,9 +312,18 @@ loadThreadState dflags tso stack = do
           storeCurCCS
             (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) (ccsType dflags))
         else mkNop]
-emitLoadThreadState :: LocalReg -> LocalReg -> FCode ()
-emitLoadThreadState tso stack = do dflags <- getDynFlags
-                                   emit $ loadThreadState dflags tso stack
+
+emitLoadThreadState :: FCode ()
+emitLoadThreadState = do
+  dflags <- getDynFlags
+  load_tso <- newTemp (gcWord dflags)
+  load_stack <- newTemp (gcWord dflags)
+  emit $ loadThreadState dflags load_tso load_stack
+
+emitOpenNursery :: FCode ()
+emitOpenNursery = do
+  df <- getDynFlags
+  emit (openNursery df)
 
 openNursery :: DynFlags -> CmmAGraph
 openNursery dflags = catAGraphs [
@@ -345,9 +345,6 @@ openNursery dflags = catAGraphs [
                 )
             )
    ]
-emitOpenNursery :: FCode ()
-emitOpenNursery = do dflags <- getDynFlags
-                     emit $ openNursery dflags
 
 nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: DynFlags -> CmmExpr
 nursery_bdescr_free   dflags = cmmOffset dflags stgCurrentNursery (oFFSET_bdescr_free dflags)
index 2abca3f..fe00d7c 100644 (file)
@@ -53,7 +53,7 @@ staticGranHdr = []
 doGranAllocate :: CmmExpr -> Code
 -- macro DO_GRAN_ALLOCATE
 doGranAllocate hp
-  | not opt_GranMacros = nopC
+  | not opt_GranMacros = return ()
   | otherwise          = panic "doGranAllocate"
 
 
@@ -75,7 +75,7 @@ granFetchAndReschedule regs node_reqd
   = do { fetch
        ; reschedule liveness node_reqd }
   | otherwise
-  = nopC
+  = return ()
   where
     liveness = mkRegLiveness regs 0 0
 
@@ -109,7 +109,7 @@ granYield :: [(Id,GlobalReg)]   -- Live registers
 
 granYield regs node_reqd
   | opt_GranMacros && node_reqd = yield liveness
-  | otherwise                   = nopC
+  | otherwise                   = return ()
   where
      liveness = mkRegLiveness regs 0 0
 
index b7cca48..c133ab0 100644 (file)
@@ -11,6 +11,8 @@ module StgCmmHeap (
         getHpRelOffset, hpRel,
 
         entryHeapCheck, altHeapCheck, noEscapeHeapCheck, altHeapCheckReturnsTo,
+        heapStackCheckGen,
+        entryHeapCheck',
 
         mkVirtHeapOffsets, mkVirtConstrOffsets,
         mkStaticClosureFields, mkStaticClosure,
@@ -47,6 +49,7 @@ import FastString( mkFastString, fsLit )
 import Util
 
 import Control.Monad (when)
+import Data.Maybe (isJust)
 
 -----------------------------------------------------------
 --              Initialise dynamic heap objects
@@ -334,16 +337,28 @@ entryHeapCheck :: ClosureInfo
                -> FCode ()
 
 entryHeapCheck cl_info nodeSet arity args code
+  = entryHeapCheck' is_fastf node arity args code
+  where
+    node = case nodeSet of
+              Just r  -> CmmReg (CmmLocal r)
+              Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)
+
+    is_fastf = case closureFunInfo cl_info of
+                 Just (_, ArgGen _) -> False
+                 _otherwise         -> True
+
+-- | lower-level version for CmmParse
+entryHeapCheck' :: Bool           -- is a known function pattern
+                -> CmmExpr        -- expression for the closure pointer
+                -> Int            -- Arity -- not same as len args b/c of voids
+                -> [LocalReg]     -- Non-void args (empty for thunk)
+                -> FCode ()
+                -> FCode ()
+entryHeapCheck' is_fastf node arity args code
   = do dflags <- getDynFlags
        let is_thunk = arity == 0
-           is_fastf = case closureFunInfo cl_info of
-                           Just (_, ArgGen _) -> False
-                           _otherwise         -> True
 
            args' = map (CmmReg . CmmLocal) args
-           node = case nodeSet of
-                      Just r  -> CmmReg (CmmLocal r)
-                      Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)
            stg_gc_fun    = CmmReg (CmmGlobal GCFun)
            stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
 
@@ -373,50 +388,6 @@ entryHeapCheck cl_info nodeSet arity args code
        emitLabel loop_id
        heapCheck True True (gc_call updfr_sz <*> mkBranch loop_id) code
 
-{-
-    -- This code is slightly outdated now and we could easily keep the above
-    -- GC methods. However, there may be some performance gains to be made by
-    -- using more specialised GC entry points. Since the semi generic GCFun
-    -- entry needs to check the node and figure out what registers to save...
-    -- if we provided and used more specialised GC entry points then these
-    -- runtime decisions could be turned into compile time decisions.
-
-    args'     = case fun of Just f  -> f : args
-                            Nothing -> args
-    arg_exprs = map (CmmReg . CmmLocal) args'
-    gc_call updfr_sz
-        | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) arg_exprs updfr_sz
-        | otherwise =
-            case gc_lbl args' of
-                Just _lbl -> panic "StgCmmHeap.entryHeapCheck: not finished"
-                            -- mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
-                            --         arg_exprs updfr_sz
-                Nothing  -> mkCall generic_gc (GC, GC) [] [] updfr_sz
-
-    gc_lbl :: [LocalReg] -> Maybe FastString
-    gc_lbl [reg]
-        | isGcPtrType ty  = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p"
-        | isFloatType ty  = case width of
-                              W32 -> Just (sLit "stg_gc_f1")
-                              W64 -> Just (sLit "stg_gc_d1")
-                              _other -> Nothing
-        | width == wordWidth dflags = Just (mkGcLabel "stg_gc_unbx_r1")
-        | width == W64              = Just (mkGcLabel "stg_gc_l1")
-        | otherwise                 = Nothing
-        where
-          ty = localRegType reg
-          width = typeWidth ty
-
-    gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs)
-
-    gc_lbl_ptrs :: [Bool] -> Maybe FastString
-    -- JD: TEMPORARY -- UNTIL THESE FUNCTIONS EXIST...
-    --gc_lbl_ptrs [True,True]      = Just (sLit "stg_gc_fun_2p")
-    --gc_lbl_ptrs [True,True,True] = Just (sLit "stg_gc_fun_3p")
-    gc_lbl_ptrs _ = Nothing
--}
-
-
 -- ------------------------------------------------------------
 -- A heap/stack check in a case alternative
 
@@ -445,7 +416,7 @@ altOrNoEscapeHeapCheck checkYield regs code = do
       Nothing -> genericGC checkYield code
       Just gc -> do
         lret <- newLabelC
-        let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs
+        let (off, copyin) = copyInOflow dflags NativeReturn (Young lret) regs []
         lcont <- newLabelC
         emitOutOfLine lret (copyin <*> mkBranch lcont)
         emitLabel lcont
@@ -475,23 +446,29 @@ cannedGCReturnsTo checkYield cont_on_stack gc regs lret off code
     reg_exprs = map (CmmReg . CmmLocal) regs
       -- Note [stg_gc arguments]
 
+      -- NB. we use the NativeReturn convention for passing arguments
+      -- to the canned heap-check routines, because we are in a case
+      -- alternative and hence the [LocalReg] was passed to us in the
+      -- NativeReturn convention.
     gc_call dflags label sp
-      | cont_on_stack = mkJumpReturnsTo dflags label GC reg_exprs lret off sp
-      | otherwise     = mkCallReturnsTo dflags label GC reg_exprs lret off sp (0,[])
+      | cont_on_stack
+      = mkJumpReturnsTo dflags label NativeReturn reg_exprs lret off sp
+      | otherwise
+      = mkCallReturnsTo dflags label NativeReturn reg_exprs lret off sp []
 
 genericGC :: Bool -> FCode a -> FCode a
 genericGC checkYield code
   = do updfr_sz <- getUpdFrameOff
        lretry <- newLabelC
        emitLabel lretry
-       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz (0,[])
+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
        heapCheck False checkYield (call <*> mkBranch lretry) code
 
 cannedGCEntryPoint :: DynFlags -> [LocalReg] -> Maybe CmmExpr
 cannedGCEntryPoint dflags regs
-  = case regs of
+  = case map localRegType regs of
       []  -> Just (mkGcLabel "stg_gc_noregs")
-      [reg]
+      [ty]
           | isGcPtrType ty -> Just (mkGcLabel "stg_gc_unpt_r1")
           | isFloatType ty -> case width of
                                   W32       -> Just (mkGcLabel "stg_gc_f1")
@@ -502,8 +479,19 @@ cannedGCEntryPoint dflags regs
           | width == W64              -> Just (mkGcLabel "stg_gc_l1")
           | otherwise                 -> Nothing
           where
-              ty = localRegType reg
               width = typeWidth ty
+      [ty1,ty2]
+          |  isGcPtrType ty1
+          && isGcPtrType ty2 -> Just (mkGcLabel "stg_gc_pp")
+      [ty1,ty2,ty3]
+          |  isGcPtrType ty1
+          && isGcPtrType ty2
+          && isGcPtrType ty3 -> Just (mkGcLabel "stg_gc_ppp")
+      [ty1,ty2,ty3,ty4]
+          |  isGcPtrType ty1
+          && isGcPtrType ty2
+          && isGcPtrType ty3
+          && isGcPtrType ty4 -> Just (mkGcLabel "stg_gc_pppp")
       _otherwise -> Nothing
 
 -- Note [stg_gc arguments]
@@ -538,51 +526,70 @@ heapCheck checkStack checkYield do_gc code
   = getHeapUsage $ \ hpHw ->
     -- Emit heap checks, but be sure to do it lazily so
     -- that the conditionals on hpHw don't cause a black hole
-    do  { codeOnly $ do_checks checkStack checkYield hpHw do_gc
+    do  { dflags <- getDynFlags
+        ; let mb_alloc_bytes
+                 | hpHw > 0  = Just (mkIntExpr dflags (hpHw * (wORD_SIZE dflags)))
+                 | otherwise = Nothing
+              stk_hwm | checkStack = Just (CmmLit CmmHighStackMark)
+                      | otherwise  = Nothing
+        ; codeOnly $ do_checks stk_hwm checkYield mb_alloc_bytes do_gc
         ; tickyAllocHeap hpHw
         ; doGranAllocate hpHw
         ; setRealHp hpHw
         ; code }
 
-do_checks :: Bool       -- Should we check the stack?
+heapStackCheckGen :: Maybe CmmExpr -> Maybe CmmExpr -> FCode ()
+heapStackCheckGen stk_hwm mb_bytes
+  = do updfr_sz <- getUpdFrameOff
+       lretry <- newLabelC
+       emitLabel lretry
+       call <- mkCall generic_gc (GC, GC) [] [] updfr_sz []
+       do_checks stk_hwm False  mb_bytes (call <*> mkBranch lretry)
+
+do_checks :: Maybe CmmExpr    -- Should we check the stack?
           -> Bool       -- Should we check for preemption?
-          -> WordOff    -- Heap headroom
+          -> Maybe CmmExpr    -- Heap headroom (bytes)
           -> CmmAGraph  -- What to do on failure
           -> FCode ()
-do_checks checkStack checkYield alloc do_gc = do
+do_checks mb_stk_hwm checkYield mb_alloc_lit do_gc = do
   dflags <- getDynFlags
+  gc_id <- newLabelC
+
   let
-    alloc_lit = mkIntExpr dflags (alloc * wORD_SIZE dflags) -- Bytes
-    bump_hp = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit
+    Just alloc_lit = mb_alloc_lit
+
+    bump_hp   = cmmOffsetExprB dflags (CmmReg hpReg) alloc_lit
 
     -- Sp overflow if (Sp - CmmHighStack < SpLim)
-    sp_oflo = CmmMachOp (mo_wordULt dflags)
+    sp_oflo sp_hwm =
+         CmmMachOp (mo_wordULt dflags)
                   [CmmMachOp (MO_Sub (typeWidth (cmmRegType dflags spReg)))
-                             [CmmReg spReg, CmmLit CmmHighStackMark],
+                             [CmmReg spReg, sp_hwm],
                    CmmReg spLimReg]
 
     -- Hp overflow if (Hp > HpLim)
     -- (Hp has been incremented by now)
     -- HpLim points to the LAST WORD of valid allocation space.
     hp_oflo = CmmMachOp (mo_wordUGt dflags)
-                        [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
-
-    -- Yielding if HpLim == 0
-    yielding = CmmMachOp (mo_wordEq dflags)
-                        [CmmReg (CmmGlobal HpLim), CmmLit (zeroCLit dflags)]
+                  [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
 
     alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit
-  gc_id <- newLabelC
 
-  when checkStack $ do
-     emit =<< mkCmmIfGoto sp_oflo gc_id
+  case mb_stk_hwm of
+    Nothing -> return ()
+    Just stk_hwm -> emit =<< mkCmmIfGoto (sp_oflo stk_hwm) gc_id
 
-  if (alloc /= 0)
+  if (isJust mb_alloc_lit)
     then do
-      emitAssign hpReg bump_hp
-      emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
+     emitAssign hpReg bump_hp
+     emit =<< mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
     else do
-      when (not (dopt Opt_OmitYields dflags) && checkYield) (emit =<< mkCmmIfGoto yielding gc_id)
+      when (not (dopt Opt_OmitYields dflags) && checkYield) $ do
+         -- Yielding if HpLim == 0
+         let yielding = CmmMachOp (mo_wordEq dflags)
+                                  [CmmReg (CmmGlobal HpLim),
+                                   CmmLit (zeroCLit dflags)]
+         emit =<< mkCmmIfGoto yielding gc_id
 
   emitOutOfLine gc_id $
      do_gc -- this is expected to jump back somewhere
index cb60e9d..85f4c16 100644 (file)
@@ -19,6 +19,8 @@ import StgCmmUtils
 import HscTypes
 import DynFlags
 
+import Control.Monad
+
 mkTickBox :: DynFlags -> Module -> Int -> CmmAGraph
 mkTickBox dflags mod n
   = mkStore tick_box (CmmMachOp (MO_Add W64)
@@ -36,7 +38,7 @@ initHpc _ (NoHpcInfo {})
   = return ()
 initHpc this_mod (HpcInfo tickCount _hashNo)
   = do dflags <- getDynFlags
-       whenC (dopt Opt_Hpc dflags) $
+       when (dopt Opt_Hpc dflags) $
            do emitDataLits (mkHpcTicksLabel this_mod)
                            [ (CmmInt 0 W64)
                            | _ <- take tickCount [0 :: Int ..]
index 75d8d1c..4742332 100644 (file)
@@ -111,7 +111,7 @@ emitCall convs fun args
 --
 emitCallWithExtraStack
    :: (Convention, Convention) -> CmmExpr -> [CmmExpr]
-   -> (ByteOff, [(CmmExpr,ByteOff)]) -> FCode ReturnKind
+   -> [CmmExpr] -> FCode ReturnKind
 emitCallWithExtraStack (callConv, retConv) fun args extra_stack
   = do { dflags <- getDynFlags
         ; adjustHpBackwards
@@ -124,7 +124,7 @@ emitCallWithExtraStack (callConv, retConv) fun args extra_stack
             AssignTo res_regs _ -> do
               k <- newLabelC
               let area = Young k
-                  (off, copyin) = copyInOflow dflags retConv area res_regs
+                  (off, copyin) = copyInOflow dflags retConv area res_regs []
                   copyout = mkCallReturnsTo dflags fun callConv args k off updfr_off
                                    extra_stack
               emit (copyout <*> mkLabel k <*> copyin)
@@ -222,7 +222,7 @@ direct_call caller call_conv lbl arity args
        emitCallWithExtraStack (call_conv, NativeReturn)
                               target
                               (nonVArgs fast_args)
-                              (mkStkOffsets dflags (stack_args dflags))
+                              (nonVArgs (stack_args dflags))
   where
     target = CmmLit (CmmLabel lbl)
     (fast_args, rest_args) = splitAt real_arity args
@@ -326,32 +326,7 @@ slowCallPattern []               = (fsLit "stg_ap_0", 0)
 
 
 -------------------------------------------------------------------------
--- Fix the byte-offsets of a bunch of things to push on the stack
-
--- This is used for pushing slow-call continuations.
--- See Note [over-saturated calls].
-
-mkStkOffsets
-  :: DynFlags
-  -> [(ArgRep, Maybe CmmExpr)]    -- things to make offsets for
-  -> ( ByteOff                    -- OUTPUTS: Topmost allocated word
-     , [(CmmExpr, ByteOff)] )     -- things with offsets (voids filtered out)
-mkStkOffsets dflags things
-    = loop 0 [] (reverse things)
-  where
-    loop offset offs [] = (offset,offs)
-    loop offset offs ((_,Nothing):things) = loop offset offs things
-       -- ignore Void arguments
-    loop offset offs ((rep,Just thing):things)
-        = loop thing_off ((thing, thing_off):offs) things
-       where
-          thing_off = offset + argRepSizeW dflags rep * wORD_SIZE dflags
-           -- offset of thing is offset+size, because we're 
-           -- growing the stack *downwards* as the offsets increase.
-
-
--------------------------------------------------------------------------
---     Classifying arguments: ArgRep
+--      Classifying arguments: ArgRep
 -------------------------------------------------------------------------
 
 -- ArgRep is not exported (even abstractly)
@@ -472,7 +447,7 @@ mkArgDescr _nm args
        let arg_bits = argBits dflags arg_reps
            arg_reps = filter isNonV (map idArgRep args)
            -- Getting rid of voids eases matching of standard patterns
-       case stdPattern dflags arg_reps of
+       case stdPattern arg_reps of
            Just spec_id -> return (ArgSpec spec_id)
            Nothing      -> return (ArgGen arg_bits)
 
@@ -483,10 +458,9 @@ argBits dflags (arg : args) = take (argRepSizeW dflags arg) (repeat True)
                     ++ argBits dflags args
 
 ----------------------
-stdPattern :: DynFlags -> [ArgRep] -> Maybe StgHalfWord
-stdPattern dflags reps
-  = fmap (toStgHalfWord dflags)
-  $ case reps of
+stdPattern :: [ArgRep] -> Maybe Int
+stdPattern reps
+  = case reps of
        []  -> Just ARG_NONE    -- just void args, probably
        [N] -> Just ARG_N
        [P] -> Just ARG_P
@@ -545,7 +519,7 @@ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args body
         ; let args' = if node_points then (node : arg_regs) else arg_regs
               conv  = if nodeMustPointToIt dflags lf_info then NativeNodeCall
                                                           else NativeDirectCall
-              (offset, _) = mkCallEntry dflags conv args'
+              (offset, _) = mkCallEntry dflags conv args' []
         ; emitClosureAndInfoTable info_tbl conv args' $ body (offset, node, arg_regs)
         }
 
index fb290d8..b7797bd 100644 (file)
@@ -18,15 +18,16 @@ module StgCmmMonad (
        FCode,  -- type
 
         initC, runC, thenC, thenFC, listCs,
-        returnFC, nopC, whenC,
+        returnFC, fixC,
        newUnique, newUniqSupply, 
 
         newLabelC, emitLabel,
 
-       emit, emitDecl, emitProc, emitProcWithConvention, emitSimpleProc,
+        emit, emitDecl, emitProc,
+        emitProcWithConvention, emitProcWithStackFrame,
         emitOutOfLine, emitAssign, emitStore, emitComment,
 
-       getCmm, cgStmtsToBlocks,
+        getCmm, aGraphToGraph,
        getCodeR, getCode, getHeapUsage,
 
         mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
@@ -89,7 +90,30 @@ infixr 9 `thenFC`
 
 
 --------------------------------------------------------
---     The FCode monad and its types
+-- The FCode monad and its types
+--
+-- FCode is the monad plumbed through the Stg->Cmm code generator, and
+-- the Cmm parser.  It contains the following things:
+--
+--  - A writer monad, collecting:
+--    - code for the current function, in the form of a CmmAGraph.
+--      The function "emit" appends more code to this.
+--    - the top-level CmmDecls accumulated so far
+--
+--  - A state monad with:
+--    - the local bindings in scope
+--    - the current heap usage
+--    - a UniqSupply
+--
+--  - A reader monad, for CgInfoDownwards, containing
+--    - DynFlags,
+--    - the current Module
+--    - the static top-level environmnet
+--    - the update-frame offset
+--    - the ticky counter label
+--    - the Sequel (the continuation to return to)
+
+
 --------------------------------------------------------
 
 newtype FCode a = FCode (CgInfoDownwards -> CgState -> (# a, CgState #))
@@ -120,13 +144,6 @@ thenC (FCode m) (FCode k) =
         FCode $ \info_down state -> case m info_down state of
                                      (# _,new_state #) -> k info_down new_state
 
-nopC :: FCode ()
-nopC = return ()
-
-whenC :: Bool -> FCode () -> FCode ()
-whenC True  code  = code
-whenC False _code = nopC
-
 listCs :: [FCode ()] -> FCode ()
 listCs [] = return ()
 listCs (fc:fcs) = do
@@ -141,6 +158,15 @@ thenFC (FCode m) k = FCode $
                  case k m_result of
                    FCode kcode -> kcode info_down new_state
 
+fixC :: (a -> FCode a) -> FCode a
+fixC fcode = FCode (
+       \info_down state -> 
+               let
+                        (v,s) = doFCode (fcode v) info_down state
+                in
+                        (# v, s #)
+       )
+
 --------------------------------------------------------
 --     The code generator environment
 --------------------------------------------------------
@@ -478,7 +504,7 @@ getSequel = do  { info <- getInfoDown
 -- Note: I'm including the size of the original return address
 -- in the size of the update frame -- hence the default case on `get'.
 
-withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode ()
+withUpdFrameOff :: UpdFrameOffset -> FCode a -> FCode a
 withUpdFrameOff size code
   = do { info  <- getInfoDown
        ; withInfoDown code (info {cgd_updfr_off = size }) }
@@ -675,31 +701,60 @@ emitDecl decl
 emitOutOfLine :: BlockId -> CmmAGraph -> FCode ()
 emitOutOfLine l stmts = emitCgStmt (CgFork l stmts)
 
+emitProcWithStackFrame
+   :: Convention                        -- entry convention
+   -> Maybe CmmInfoTable                -- info table?
+   -> CLabel                            -- label for the proc
+   -> [CmmFormal]                       -- stack frame
+   -> [CmmFormal]                       -- arguments
+   -> CmmAGraph                         -- code
+   -> Bool                              -- do stack layout?
+   -> FCode ()
+
+emitProcWithStackFrame _conv mb_info lbl _stk_args [] blocks False
+  = do  { dflags <- getDynFlags
+        ; emitProc_ mb_info lbl blocks (widthInBytes (wordWidth dflags)) False
+        }
+emitProcWithStackFrame conv mb_info lbl stk_args args blocks True -- do layout
+  = do  { dflags <- getDynFlags
+        ; let (offset, entry) = mkCallEntry dflags conv args stk_args
+        ; emitProc_ mb_info lbl (entry <*> blocks) offset True
+        }
+emitProcWithStackFrame _ _ _ _ _ _ _ = panic "emitProcWithStackFrame"
+
 emitProcWithConvention :: Convention -> Maybe CmmInfoTable -> CLabel
-                       -> [CmmFormal] -> CmmAGraph -> FCode ()
+                       -> [CmmFormal]
+                       -> CmmAGraph
+                       -> FCode ()
 emitProcWithConvention conv mb_info lbl args blocks
+  = emitProcWithStackFrame conv mb_info lbl [] args blocks True
+
+emitProc :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> FCode ()
+emitProc  mb_info lbl blocks offset
+ = emitProc_ mb_info lbl blocks offset True
+
+emitProc_ :: Maybe CmmInfoTable -> CLabel -> CmmAGraph -> Int -> Bool
+          -> FCode ()
+emitProc_ mb_info lbl blocks offset do_layout
   = do  { dflags <- getDynFlags
-        ; us <- newUniqSupply
-        ; let (offset, entry) = mkCallEntry dflags conv args
-              blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
-        ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just (initUpdFrameOff dflags)}
-              tinfo = TopInfo {info_tbls = infos, stack_info=sinfo}
-              proc_block = CmmProc tinfo lbl blks
+        ; l <- newLabelC
+        ; let
+              blks = labelAGraph l blocks
 
-              infos | Just info <- mb_info
-                    = mapSingleton (g_entry blks) info
-                    | otherwise
-                    = mapEmpty
+              infos | Just info <- mb_info = mapSingleton (g_entry blks) info
+                    | otherwise            = mapEmpty
 
-        ; state <- getState
-        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+              sinfo = StackInfo { arg_space = offset
+                                , updfr_space = Just (initUpdFrameOff dflags)
+                                , do_layout = do_layout }
+
+              tinfo = TopInfo { info_tbls = infos
+                              , stack_info=sinfo}
 
-emitProc :: Maybe CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode ()
-emitProc = emitProcWithConvention NativeNodeCall
+              proc_block = CmmProc tinfo lbl blks
 
-emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
-emitSimpleProc lbl code = 
-  emitProc Nothing lbl [] code
+        ; state <- getState
+        ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
 
 getCmm :: FCode () -> FCode CmmGroup
 -- Get all the CmmTops (there should be no stmts)
@@ -735,29 +790,25 @@ mkCmmIfThen e tbranch = do
 
 
 mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual]
-       -> UpdFrameOffset -> (ByteOff,[(CmmExpr,ByteOff)]) -> FCode CmmAGraph
+       -> UpdFrameOffset -> [CmmActual] -> FCode CmmAGraph
 mkCall f (callConv, retConv) results actuals updfr_off extra_stack = do
   dflags <- getDynFlags
   k <- newLabelC
   let area = Young k
-      (off, copyin) = copyInOflow dflags retConv area results
+      (off, copyin) = copyInOflow dflags retConv area results []
       copyout = mkCallReturnsTo dflags f callConv actuals k off updfr_off extra_stack
   return (copyout <*> mkLabel k <*> copyin)
 
 mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset
           -> FCode CmmAGraph
 mkCmmCall f results actuals updfr_off
-   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off (0,[])
+   = mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off []
 
 
 -- ----------------------------------------------------------------------------
--- CgStmts
-
--- These functions deal in terms of CgStmts, which is an abstract type
--- representing the code in the current proc.
+-- turn CmmAGraph into CmmGraph, for making a new proc.
 
--- turn CgStmts into [CmmBasicBlock], for making a new proc.
-cgStmtsToBlocks :: CmmAGraph -> FCode CmmGraph
-cgStmtsToBlocks stmts
-  = do  { us <- newUniqSupply
-       ; return (initUs_ us (lgraphOfAGraph stmts)) }  
+aGraphToGraph :: CmmAGraph -> FCode CmmGraph
+aGraphToGraph stmts
+  = do  { l <- newLabelC
+        ; return (labelAGraph l stmts) }
index cbb2aa7..97104ce 100644 (file)
@@ -97,7 +97,7 @@ cgOpApp (StgPrimOp primop) args res_ty
   | primOpOutOfLine primop
   = do { cmm_args <- getNonVoidArgAmodes args
         ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop))
-        ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args }
+        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
 
   | ReturnsPrim VoidRep <- result_info
   = do cgPrimOp [] primop args 
@@ -130,7 +130,7 @@ cgOpApp (StgPrimOp primop) args res_ty
 cgOpApp (StgPrimCallOp primcall) args _res_ty
   = do { cmm_args <- getNonVoidArgAmodes args
         ; let fun = CmmLit (CmmLabel (mkPrimCallLabel primcall))
-        ; emitCall (PrimOpCall, PrimOpReturn) fun cmm_args }
+        ; emitCall (NativeNodeCall, NativeReturn) fun cmm_args }
 
 ---------------------------------------------------
 cgPrimOp   :: [LocalReg]       -- where to put the results
index b666554..1b21846 100644 (file)
@@ -82,24 +82,22 @@ costCentreFrom :: DynFlags
               -> CmmExpr       -- The cost centre from that closure
 costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)
 
+-- | The profiling header words in a static closure
 staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
--- The profiling header words in a static closure
--- Was SET_STATIC_PROF_HDR
 staticProfHdr dflags ccs
  = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]
 
+-- | Profiling header words in a dynamic closure
 dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
--- Profiling header words in a dynamic closure
 dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
 
-initUpdFrameProf :: ByteOff -> FCode ()
--- Initialise the profiling field of an update frame
-initUpdFrameProf frame_off
+-- | Initialise the profiling field of an update frame
+initUpdFrameProf :: CmmExpr -> FCode ()
+initUpdFrameProf frame
   = ifProfiling $      -- frame->header.prof.ccs = CCCS
     do dflags <- getDynFlags
-       emitStore (CmmStackSlot Old (frame_off - oFFSET_StgHeader_ccs dflags))
-                 curCCS
-       -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) 
+       emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) curCCS
+        -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
        -- is unnecessary because it is not used anyhow.
 
 ---------------------------------------------------------------------------
@@ -200,7 +198,7 @@ ifProfiling code
   = do dflags <- getDynFlags
        if dopt Opt_SccProfilingOn dflags
            then code
-           else nopC
+           else return ()
 
 ifProfilingL :: DynFlags -> [a] -> [a]
 ifProfilingL dflags xs
@@ -216,7 +214,7 @@ initCostCentres :: CollectedCCs -> FCode ()
 -- Emit the declarations
 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
   = do dflags <- getDynFlags
-       whenC (dopt Opt_SccProfilingOn dflags) $
+       when (dopt Opt_SccProfilingOn dflags) $
            do mapM_ emitCostCentreDecl local_CCs
               mapM_ emitCostCentreStackDecl singleton_CCSs
 
@@ -283,7 +281,7 @@ emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
 emitSetCCC cc tick push
  = do dflags <- getDynFlags
       if not (dopt Opt_SccProfilingOn dflags)
-          then nopC
+          then return ()
           else do tmp <- newTemp (ccsType dflags) -- TODO FIXME NOW
                   pushCostCentre tmp curCCS cc
                   when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
@@ -321,7 +319,7 @@ dynLdvInit :: DynFlags -> CmmExpr
 dynLdvInit dflags =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE  
   CmmMachOp (mo_wordOr dflags) [
       CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],
-      CmmLit (mkWordCLit dflags (lDV_STATE_CREATE dflags))
+      CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))
   ]
         
 --
@@ -350,8 +348,8 @@ ldvEnter cl_ptr = do
     let -- don't forget to substract node's tag
         ldv_wd = ldvWord dflags cl_ptr
         new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
-                                                         (CmmLit (mkWordCLit dflags (lDV_CREATE_MASK dflags))))
-                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (lDV_STATE_USE dflags))))
+                                                         (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))
+                                      (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))
     ifProfiling $
          -- if (era > 0) {
          --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
@@ -371,10 +369,3 @@ ldvWord :: DynFlags -> CmmExpr -> CmmExpr
 ldvWord dflags closure_ptr
     = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
 
-lDV_CREATE_MASK :: DynFlags -> StgWord
-lDV_CREATE_MASK dflags = toStgWord dflags (iLDV_CREATE_MASK dflags)
-lDV_STATE_CREATE :: DynFlags -> StgWord
-lDV_STATE_CREATE dflags = toStgWord dflags (iLDV_STATE_CREATE dflags)
-lDV_STATE_USE :: DynFlags -> StgWord
-lDV_STATE_USE dflags = toStgWord dflags (iLDV_STATE_USE dflags)
-
index 79ad3ff..01babb2 100644 (file)
@@ -333,7 +333,7 @@ tickyAllocHeap hp
 ifTicky :: FCode () -> FCode ()
 ifTicky code = do dflags <- getDynFlags
                   if dopt Opt_Ticky dflags then code
-                                           else nopC
+                                           else return ()
 
 -- All the ticky-ticky counters are declared "unsigned long" in C
 bumpTickyCounter :: FastString -> FCode ()
index 386e7f4..138e00e 100644 (file)
@@ -36,7 +36,6 @@ module StgCmmUtils (
         addToMem, addToMemE, addToMemLbl,
         mkWordCLit,
         newStringCLit, newByteStringCLit,
-        packHalfWordsCLit,
         blankWord
   ) where
 
@@ -196,9 +195,9 @@ emitRtsCallGen res pkg fun args safe
     call updfr_off =
       if safe then
         emit =<< mkCmmCall fun_expr res' args' updfr_off
-      else
-        emit $ mkUnsafeCall (ForeignTarget fun_expr
-                         (ForeignConvention CCallConv arg_hints res_hints)) res' args'
+      else do
+        let conv = ForeignConvention CCallConv arg_hints res_hints CmmMayReturn
+        emit $ mkUnsafeCall (ForeignTarget fun_expr conv) res' args'
     (args', arg_hints) = unzip args
     (res',  res_hints) = unzip res
     fun_expr = mkLblExpr (mkCmmCodeLabel pkg fun)
index 6d83150..888ff1a 100644 (file)
@@ -214,7 +214,6 @@ Library
         CgClosure
         CgCon
         CgExpr
-        CgExtCode
         CgForeignCall
         CgHeapery
         CgHpc
@@ -244,6 +243,7 @@ Library
         StgCmmProf
         StgCmmTicky
         StgCmmUtils
+        StgCmmExtCode
         ClosureInfo
         SMRep
         CoreArity
index 448bd4d..207a237 100644 (file)
@@ -274,7 +274,6 @@ genCall env target res args ret = do
             CCallConv    -> CC_Ccc
             CApiConv     -> CC_Ccc
             PrimCallConv -> CC_Ccc
-            CmmCallConv  -> panic "CmmCallConv not supported here!"
 
     {-
         Some of the possibilities here are a worry with the use of a custom
index 04f89bf..62a4720 100644 (file)
@@ -1349,7 +1349,11 @@ hscCompileCmmFile hsc_env filename = runHsc hsc_env $ do
     let dflags = hsc_dflags hsc_env
     cmm <- ioMsgMaybe $ parseCmmFile dflags filename
     liftIO $ do
-        rawCmms <- cmmToRawCmm dflags (Stream.yield cmm)
+        us <- mkSplitUniqSupply 'S'
+        let initTopSRT = initUs_ us emptySRT
+        dumpIfSet_dyn dflags Opt_D_dump_cmmz "Parsed Cmm" (ppr cmm)
+        (_, cmmgroup) <- cmmPipeline hsc_env initTopSRT cmm
+        rawCmms <- cmmToRawCmm dflags (Stream.yield (cmmOfZgraph cmmgroup))
         _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms
         return ()
   where
index 47fd96c..d0e4a17 100644 (file)
@@ -971,12 +971,13 @@ cmmStmtConFold stmt
 cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
 cmmExprConFold referenceKind expr = do
     dflags <- getDynFlags
-    -- Skip constant folding if new code generator is running
-    -- (this optimization is done in Hoopl)
-    -- SDM: re-enabled for now, while cmmRewriteAssignments is turned off
-    let expr' = if False -- dopt Opt_TryNewCodeGen dflags
+
+    -- With -O1 and greater, the cmmSink pass does constant-folding, so
+    -- we don't need to do it again here.
+    let expr' = if optLevel dflags >= 1
                     then expr
                     else cmmExprCon dflags expr
+
     cmmExprNative referenceKind expr'
 
 cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr
index a15bca0..3f1efe5 100644 (file)
@@ -434,10 +434,21 @@ raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live))
                         (uniqSetToList $ liveDieRead live)
                         (uniqSetToList $ liveDieWrite live)
 
-
 raInsn _ _ _ instr
         = pprPanic "raInsn" (text "no match for:" <> ppr instr)
 
+-- ToDo: what can we do about
+--
+--     R1 = x
+--     jump I64[x] // [R1]
+--
+-- where x is mapped to the same reg as R1.  We want to coalesce x and
+-- R1, but the register allocator doesn't know whether x will be
+-- assigned to again later, in which case x and R1 should be in
+-- different registers.  Right now we assume the worst, and the
+-- assignment to R1 will clobber x, so we'll spill x into another reg,
+-- generating another reg->reg move.
+
 
 isInReg :: Reg -> RegMap Loc -> Bool
 isInReg src assig | Just (InReg _) <- lookupUFM assig src = True
index b3a2ad3..b53ae7c 100644 (file)
@@ -156,8 +156,7 @@ platforms.
 See: http://www.programmersheaven.com/2/Calling-conventions
 
 \begin{code}
-data CCallConv = CCallConv | CApiConv | StdCallConv
-               | CmmCallConv | PrimCallConv
+data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv
   deriving (Eq, Data, Typeable)
   {-! derive: Binary !-}
 
@@ -165,7 +164,6 @@ instance Outputable CCallConv where
   ppr StdCallConv = ptext (sLit "stdcall")
   ppr CCallConv   = ptext (sLit "ccall")
   ppr CApiConv    = ptext (sLit "capi")
-  ppr CmmCallConv = ptext (sLit "C--")
   ppr PrimCallConv = ptext (sLit "prim")
 
 defaultCCallConv :: CCallConv
@@ -175,7 +173,6 @@ ccallConvToInt :: CCallConv -> Int
 ccallConvToInt StdCallConv = 0
 ccallConvToInt CCallConv   = 1
 ccallConvToInt CApiConv    = panic "ccallConvToInt CApiConv"
-ccallConvToInt (CmmCallConv {})  = panic "ccallConvToInt CmmCallConv"
 ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
 \end{code}
 
@@ -187,7 +184,6 @@ ccallConvAttribute :: CCallConv -> SDoc
 ccallConvAttribute StdCallConv       = text "__attribute__((__stdcall__))"
 ccallConvAttribute CCallConv         = empty
 ccallConvAttribute CApiConv          = empty
-ccallConvAttribute (CmmCallConv {})  = panic "ccallConvAttribute CmmCallConv"
 ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
 \end{code}
 
@@ -326,17 +322,14 @@ instance Binary CCallConv where
             putByte bh 1
     put_ bh PrimCallConv = do
             putByte bh 2
-    put_ bh CmmCallConv = do
-            putByte bh 3
     put_ bh CApiConv = do
-            putByte bh 4
+            putByte bh 3
     get bh = do
             h <- getByte bh
             case h of
               0 -> do return CCallConv
               1 -> do return StdCallConv
               2 -> do return PrimCallConv
-              3 -> do return CmmCallConv
               _ -> do return CApiConv
 
 instance Binary CType where
index 90a1740..9c8b980 100644 (file)
@@ -464,7 +464,6 @@ checkCConv StdCallConv  = do dflags <- getDynFlags
                                          return CCallConv
 checkCConv PrimCallConv = do addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
                              return PrimCallConv
-checkCConv CmmCallConv  = panic "checkCConv CmmCallConv"
 \end{code}
 
 Warnings
index edcf46e..afe08a2 100644 (file)
@@ -9,36 +9,6 @@
  *
  * For the syntax of .cmm files, see the parser in ghc/compiler/cmm/CmmParse.y.
  *
- * If you're used to the old HC file syntax, here's a quick cheat sheet
- * for converting HC code:
- *
- *       - Remove FB_/FE_
- *       - Remove all type casts
- *       - Remove '&'
- *       - STGFUN(foo) { ... }  ==>  foo { ... }
- *       - FN_(foo) { ... }  ==>  foo { ... }
- *       - JMP_(e)  ==> jump e;
- *       - Remove EXTFUN(foo)
- *       - Sp[n]  ==>  Sp(n)
- *       - Hp[n]  ==>  Hp(n)
- *       - Sp += n  ==> Sp_adj(n)
- *       - Hp += n  ==> Hp_adj(n)
- *       - R1.i   ==>  R1   (similarly for R1.w, R1.cl etc.)
- *       - You need to explicitly dereference variables; eg. 
- *             alloc_blocks   ==>  CInt[alloc_blocks]
- *       - convert all word offsets into byte offsets:
- *             - e ==> WDS(e)
- *       - sizeofW(StgFoo)  ==>  SIZEOF_StgFoo
- *       - ENTRY_CODE(e)  ==>  %ENTRY_CODE(e)
- *       - get_itbl(c)  ==>  %GET_STD_INFO(c)
- *       - Change liveness masks in STK_CHK_GEN, HP_CHK_GEN:
- *             R1_PTR | R2_PTR  ==>  R1_PTR & R2_PTR
- *             (NOTE: | becomes &)
- *       - Declarations like 'StgPtr p;' become just 'W_ p;'
- *       - e->payload[n] ==> PAYLOAD(e,n)
- *       - Be very careful with comparisons: the infix versions (>, >=, etc.)
- *         are unsigned, so use %lt(a,b) to get signed less-than for example.
- *
  * Accessing fields of structures defined in the RTS header files is
  * done via automatically-generated macros in DerivedConstants.h.  For
  * example, where previously we used
    Misc useful stuff
    -------------------------------------------------------------------------- */
 
+#define ccall foreign "C"
+
 #define NULL (0::W_)
 
 #define STRING(name,str)                       \
 #define Sp(n)  W_[Sp + WDS(n)]
 #define Hp(n)  W_[Hp + WDS(n)]
 
-#define Sp_adj(n) Sp = Sp + WDS(n)
+#define Sp_adj(n) Sp = Sp + WDS(n)  /* pronounced "spadge" */
 #define Hp_adj(n) Hp = Hp + WDS(n)
 
 /* -----------------------------------------------------------------------------
 #define LOAD_INFO \
     info = %INFO_PTR(UNTAG(P1));
 
-#define UNTAG_R1 \
-    P1 = UNTAG(P1);
+#define MAYBE_UNTAG(x) UNTAG(x);
 
 #else
 
-#define LOAD_INFO                               \
-  if (GETTAG(P1) != 0) {                        \
-      jump %ENTRY_CODE(Sp(0));                  \
+#define LOAD_INFO(ret,x)                        \
+  if (GETTAG(x) != 0) {                         \
+      ret(x);                                   \
   }                                             \
-  info = %INFO_PTR(P1);
+  info = %INFO_PTR(x);
 
-#define UNTAG_R1 /* nothing */
+#define MAYBE_UNTAG(x) (x) /* already untagged */
 
 #endif
 
-#define ENTER()                                                \
+// We need two versions of ENTER():
+//  - ENTER(x) takes the closure as an argument and uses return(),
+//    for use in civilized code where the stack is handled by GHC
+//
+//  - ENTER_NOSTACK() where the closure is in R1, and returns are
+//    explicit jumps, for use when we are doing the stack management
+//    ourselves.
+
+#define ENTER(x) ENTER_(return,x)
+#define ENTER_R1() ENTER_(RET_R1,R1)
+
+#define RET_R1(x) jump %ENTRY_CODE(Sp(0)) [R1]
+
+#define ENTER_(ret,x)                                   \
  again:                                                        \
   W_ info;                                             \
-  LOAD_INFO                                             \
+  LOAD_INFO(ret,x)                                       \
   switch [INVALID_OBJECT .. N_CLOSURE_TYPES]           \
          (TO_W_( %INFO_TYPE(%STD_INFO(info)) )) {      \
   case                                                 \
     IND_PERM,                                          \
     IND_STATIC:                                                \
    {                                                   \
-      P1 = StgInd_indirectee(P1);                      \
+      x = StgInd_indirectee(x);                         \
       goto again;                                      \
    }                                                   \
   case                                                 \
     BCO,                                               \
     PAP:                                               \
    {                                                   \
-      jump %ENTRY_CODE(Sp(0));                         \
+       ret(x);                                          \
    }                                                   \
   default:                                             \
    {                                                   \
-      UNTAG_R1                                          \
-      jump %ENTRY_CODE(info);                          \
+       x = MAYBE_UNTAG(x);                              \
+       jump %ENTRY_CODE(info) (x);                      \
    }                                                   \
   }
 
  */
 #include "stg/RtsMachRegs.h"
 
-#include "rts/storage/Liveness.h"
 #include "rts/prof/LDV.h"
 
 #undef BLOCK_SIZE
 #define MyCapability()  (BaseReg - OFFSET_Capability_r)
 
 /* -------------------------------------------------------------------------
+   Info tables
+   ------------------------------------------------------------------------- */
+
+#if defined(PROFILING)
+#define PROF_HDR_FIELDS(w_)                     \
+  w_ prof_hdr_1,                                \
+  w_ prof_hdr_2,
+#else
+#define PROF_HDR_FIELDS(w_) /* nothing */
+#endif
+
+/* -------------------------------------------------------------------------
    Allocation and garbage collection
    ------------------------------------------------------------------------- */
 
  * ticky-ticky.  It's not clear whether eg. the size field of an array
  * should be counted as "admin", or the various fields of a BCO.
  */
-#define ALLOC_PRIM(bytes,liveness,reentry)                     \
-   HP_CHK_GEN_TICKY(bytes,liveness,reentry);                   \
+#define ALLOC_PRIM(bytes)                                       \
+   HP_CHK_GEN_TICKY(bytes);                                     \
    TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \
    CCCS_ALLOC(bytes);
 
+#define HEAP_CHECK(bytes,failure)                       \
+    Hp = Hp + bytes;                                    \
+    if (Hp > HpLim) { HpAlloc = bytes; failure; }       \
+    TICK_ALLOC_HEAP_NOCTR(bytes);
+
+#define ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,failure)           \
+    HEAP_CHECK(bytes,failure)                                   \
+    TICK_ALLOC_PRIM(SIZEOF_StgHeader,bytes-SIZEOF_StgHeader,0); \
+    CCCS_ALLOC(bytes);
+
+#define ALLOC_PRIM_P(bytes,fun,arg)                             \
+    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_P(fun,arg));
+
+#define ALLOC_PRIM_N(bytes,fun,arg)                             \
+    ALLOC_PRIM_WITH_CUSTOM_FAILURE(bytes,GC_PRIM_N(fun,arg));
+
 /* CCS_ALLOC wants the size in words, because ccs->mem_alloc is in words */
 #define CCCS_ALLOC(__alloc) CCS_ALLOC(BYTES_TO_WDS(__alloc), CCCS)
 
-#define HP_CHK_GEN_TICKY(alloc,liveness,reentry)       \
-   HP_CHK_GEN(alloc,liveness,reentry);                 \
+#define HP_CHK_GEN_TICKY(alloc)                 \
+   HP_CHK_GEN(alloc);                           \
    TICK_ALLOC_HEAP_NOCTR(alloc);
 
+#define HP_CHK_P(bytes, fun, arg)               \
+   HEAP_CHECK(bytes, GC_PRIM_P(fun,arg))
+
+#define ALLOC_P_TICKY(alloc, fun, arg)         \
+   HP_CHK_P(alloc);                           \
+   TICK_ALLOC_HEAP_NOCTR(alloc);
+
+#define CHECK_GC()                                                      \
+  (bdescr_link(CurrentNursery) == NULL ||                               \
+   generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim]))
+
 // allocate() allocates from the nursery, so we check to see
 // whether the nursery is nearly empty in any function that uses
 // allocate() - this includes many of the primops.
-#define MAYBE_GC(liveness,reentry)                     \
-    if (bdescr_link(CurrentNursery) == NULL || \
-        generation_n_new_large_words(W_[g0]) >= TO_W_(CLong[large_alloc_lim])) {   \
-       R9  = liveness;                                 \
-        R10 = reentry;                                 \
-        HpAlloc = 0;                                   \
-        jump stg_gc_gen_hp;                            \
+//
+// HACK alert: the __L__ stuff is here to coax the common-block
+// eliminator into commoning up the call stg_gc_noregs() with the same
+// code that gets generated by a STK_CHK_GEN() in the same proc.  We
+// also need an if (0) { goto __L__; } so that the __L__ label isn't
+// optimised away by the control-flow optimiser prior to common-block
+// elimination (it will be optimised away later).
+//
+// This saves some code in gmp-wrappers.cmm where we have lots of
+// MAYBE_GC() in the same proc as STK_CHK_GEN().
+//
+#define MAYBE_GC(retry)                         \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        goto __L__;                             \
+  __L__:                                        \
+        call stg_gc_noregs();                   \
+        goto retry;                             \
+   }                                            \
+   if (0) { goto __L__; }
+
+#define GC_PRIM(fun)                            \
+        R9 = fun;                               \
+        jump stg_gc_prim();
+
+#define GC_PRIM_N(fun,arg)                      \
+        R9 = fun;                               \
+        jump stg_gc_prim_n(arg);
+
+#define GC_PRIM_P(fun,arg)                      \
+        R9 = fun;                               \
+        jump stg_gc_prim_p(arg);
+
+#define GC_PRIM_PP(fun,arg1,arg2)               \
+        R9 = fun;                               \
+        jump stg_gc_prim_pp(arg1,arg2);
+
+#define MAYBE_GC_(fun)                          \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        GC_PRIM(fun)                            \
+   }
+
+#define MAYBE_GC_N(fun,arg)                     \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        GC_PRIM_N(fun,arg)                      \
+   }
+
+#define MAYBE_GC_P(fun,arg)                     \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        GC_PRIM_P(fun,arg)                      \
    }
 
+#define MAYBE_GC_PP(fun,arg1,arg2)              \
+    if (CHECK_GC()) {                           \
+        HpAlloc = 0;                            \
+        GC_PRIM_PP(fun,arg1,arg2)               \
+   }
+
+#define STK_CHK(n, fun)                         \
+    if (Sp - n < SpLim) {                       \
+        GC_PRIM(fun)                            \
+    }
+
+#define STK_CHK_P(n, fun, arg)                  \
+    if (Sp - n < SpLim) {                       \
+        GC_PRIM_P(fun,arg)                      \
+    }
+
+#define STK_CHK_PP(n, fun, arg1, arg2)          \
+    if (Sp - n < SpLim) {                       \
+        GC_PRIM_PP(fun,arg1,arg2)               \
+    }
+
+#define STK_CHK_ENTER(n, closure)               \
+    if (Sp - n < SpLim) {                       \
+        jump __stg_gc_enter_1(closure);         \
+    }
+
+// A funky heap check used by AutoApply.cmm
+
+#define HP_CHK_NP_ASSIGN_SP0(size,f)                    \
+    HEAP_CHECK(size, Sp(0) = f; jump __stg_gc_enter_1 [R1];)
+
 /* -----------------------------------------------------------------------------
    Closure headers
    -------------------------------------------------------------------------- */
 #endif
 
 /* -----------------------------------------------------------------------------
-   Voluntary Yields/Blocks
-
-   We only have a generic version of this at the moment - if it turns
-   out to be slowing us down we can make specialised ones.
-   -------------------------------------------------------------------------- */
-
-#define YIELD(liveness,reentry)                        \
-   R9  = liveness;                             \
-   R10 = reentry;                              \
-   jump stg_gen_yield;
-
-#define BLOCK(liveness,reentry)                        \
-   R9  = liveness;                             \
-   R10 = reentry;                              \
-   jump stg_gen_block;
-
-/* -----------------------------------------------------------------------------
    Ticky macros 
    -------------------------------------------------------------------------- */
 
     TICK_BUMP_BY(ALLOC_HEAP_tot,n)
 
 /* -----------------------------------------------------------------------------
+   Saving and restoring STG registers
+
+   STG registers must be saved around a C call, just in case the STG
+   register is mapped to a caller-saves machine register.  Normally we
+   don't need to worry about this the code generator has already
+   loaded any live STG registers into variables for us, but in
+   hand-written low-level Cmm code where we don't know which registers
+   are live, we might have to save them all.
+   -------------------------------------------------------------------------- */
+
+#define SAVE_STGREGS                            \
+    W_ r1, r2, r3,  r4,  r5,  r6,  r7,  r8;     \
+    F_ f1, f2, f3, f4;                          \
+    D_ d1, d2;                                  \
+    L_ l1;                                      \
+                                                \
+    r1 = R1;                                    \
+    r2 = R2;                                    \
+    r3 = R3;                                    \
+    r4 = R4;                                    \
+    r5 = R5;                                    \
+    r6 = R6;                                    \
+    r7 = R7;                                    \
+    r8 = R8;                                    \
+                                                \
+    f1 = F1;                                    \
+    f2 = F2;                                    \
+    f3 = F3;                                    \
+    f4 = F4;                                    \
+                                                \
+    d1 = D1;                                    \
+    d2 = D2;                                    \
+                                                \
+    l1 = L1;
+
+
+#define RESTORE_STGREGS                         \
+    R1 = r1;                                    \
+    R2 = r2;                                    \
+    R3 = r3;                                    \
+    R4 = r4;                                    \
+    R5 = r5;                                    \
+    R6 = r6;                                    \
+    R7 = r7;                                    \
+    R8 = r8;                                    \
+                                                \
+    F1 = f1;                                    \
+    F2 = f2;                                    \
+    F3 = f3;                                    \
+    F4 = f4;                                    \
+                                                \
+    D1 = d1;                                    \
+    D2 = d2;                                    \
+                                                \
+    L1 = l1;
+
+/* -----------------------------------------------------------------------------
    Misc junk
    -------------------------------------------------------------------------- */
 
 #define END_TSO_QUEUE             stg_END_TSO_QUEUE_closure
 #define END_INVARIANT_CHECK_QUEUE stg_END_INVARIANT_CHECK_QUEUE_closure
 
-#define recordMutableCap(p, gen, regs)                                 \
+#define recordMutableCap(p, gen)                                        \
   W_ __bd;                                                             \
   W_ mut_list;                                                         \
   mut_list = Capability_mut_lists(MyCapability()) + WDS(gen);          \
  __bd = W_[mut_list];                                                  \
   if (bdescr_free(__bd) >= bdescr_start(__bd) + BLOCK_SIZE) {          \
       W_ __new_bd;                                                     \
-      ("ptr" __new_bd) = foreign "C" allocBlock_lock() [regs];         \
+      ("ptr" __new_bd) = foreign "C" allocBlock_lock();                        \
       bdescr_link(__new_bd) = __bd;                                    \
       __bd = __new_bd;                                                 \
       W_[mut_list] = __bd;                                             \
   W_[free] = p;                                                                \
   bdescr_free(__bd) = free + WDS(1);
 
-#define recordMutable(p, regs)                                  \
+#define recordMutable(p)                                        \
       P_ __p;                                                   \
       W_ __bd;                                                  \
       W_ __gen;                                                 \
       __p = p;                                                  \
       __bd = Bdescr(__p);                                       \
       __gen = TO_W_(bdescr_gen_no(__bd));                       \
-      if (__gen > 0) { recordMutableCap(__p, __gen, regs); }
+      if (__gen > 0) { recordMutableCap(__p, __gen); }
 
 #endif /* CMM_H */
index c52fe63..b317768 100644 (file)
@@ -208,7 +208,6 @@ INLINE_HEADER Time fsecondsToTime (double t)
 #include "rts/storage/FunTypes.h"
 #include "rts/storage/InfoTables.h"
 #include "rts/storage/Closures.h"
-#include "rts/storage/Liveness.h"
 #include "rts/storage/ClosureTypes.h"
 #include "rts/storage/TSO.h"
 #include "stg/MiscClosures.h" /* InfoTables, closures etc. defined in the RTS */
index cd741be..2fab041 100644 (file)
    pushed in one of the heap check fragments in HeapStackCheck.hc
    (ie. currently the generic heap checks - 3 words for StgRetDyn,
    18 words for the saved registers, see StgMacros.h).
-
-   In the event of an unboxed tuple or let-no-escape stack/heap check
-   failure, there will be other words on the stack which are covered
-   by the RET_DYN frame.  These will have been accounted for by stack
-   checks however, so we don't need to allow for them here.
    -------------------------------------------------------------------------- */
 
 #define RESERVED_STACK_WORDS 21
  */
 #define TSO_SQUEEZED 128
 
-/* -----------------------------------------------------------------------------
-   RET_DYN stack frames
-   -------------------------------------------------------------------------- */
-
-/* VERY MAGIC CONSTANTS!
- * must agree with code in HeapStackCheck.c, stg_gen_chk, and
- * RESERVED_STACK_WORDS in Constants.h.
- */
-#define RET_DYN_BITMAP_SIZE 8
-#define RET_DYN_NONPTR_REGS_SIZE 10
-
-/* Sanity check that RESERVED_STACK_WORDS is reasonable.  We can't
- * just derive RESERVED_STACK_WORDS because it's used in Haskell code
- * too.
- */
-#if RESERVED_STACK_WORDS != (3 + RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE)
-#error RESERVED_STACK_WORDS may be wrong!
-#endif
-
 /*
  * The number of times we spin in a spin lock before yielding (see
  * #3758).  To tune this value, use the benchmark in #3758: run the
index 6fdd557..dd5f428 100644 (file)
@@ -410,14 +410,6 @@ EXTERN_INLINE StgWord stack_frame_sizeW( StgClosure *frame )
     info = get_ret_itbl(frame);
     switch (info->i.type) {
 
-    case RET_DYN:
-    {
-       StgRetDyn *dyn = (StgRetDyn *)frame;
-       return  sizeofW(StgRetDyn) + RET_DYN_BITMAP_SIZE + 
-           RET_DYN_NONPTR_REGS_SIZE +
-           RET_DYN_PTRS(dyn->liveness) + RET_DYN_NONPTRS(dyn->liveness);
-    }
-           
     case RET_FUN:
        return sizeofW(StgRetFun) + ((StgRetFun *)frame)->size;
 
index 75ec08b..4e3b1e6 100644 (file)
 #define RET_BCO                 31
 #define RET_SMALL              32
 #define RET_BIG                        33
-#define RET_DYN                        34
-#define RET_FUN                 35
-#define UPDATE_FRAME           36
-#define CATCH_FRAME            37
-#define UNDERFLOW_FRAME         38
-#define STOP_FRAME              39
-#define BLOCKING_QUEUE         40
-#define BLACKHOLE              41
-#define MVAR_CLEAN             42
-#define MVAR_DIRTY             43
-#define ARR_WORDS              44
-#define MUT_ARR_PTRS_CLEAN      45
-#define MUT_ARR_PTRS_DIRTY      46
-#define MUT_ARR_PTRS_FROZEN0    47
-#define MUT_ARR_PTRS_FROZEN     48
-#define MUT_VAR_CLEAN          49
-#define MUT_VAR_DIRTY          50
-#define WEAK                   51
-#define PRIM                   52
-#define MUT_PRIM                53
-#define TSO                    54
-#define STACK                   55
-#define TREC_CHUNK              56
-#define ATOMICALLY_FRAME        57
-#define CATCH_RETRY_FRAME       58
-#define CATCH_STM_FRAME         59
-#define WHITEHOLE               60
-#define N_CLOSURE_TYPES         61
+#define RET_FUN                 34
+#define UPDATE_FRAME           35
+#define CATCH_FRAME            36
+#define UNDERFLOW_FRAME         37
+#define STOP_FRAME              38
+#define BLOCKING_QUEUE          39
+#define BLACKHOLE              40
+#define MVAR_CLEAN             41
+#define MVAR_DIRTY             42
+#define ARR_WORDS              43
+#define MUT_ARR_PTRS_CLEAN      44
+#define MUT_ARR_PTRS_DIRTY      45
+#define MUT_ARR_PTRS_FROZEN0    46
+#define MUT_ARR_PTRS_FROZEN     47
+#define MUT_VAR_CLEAN          48
+#define MUT_VAR_DIRTY           49
+#define WEAK                   50
+#define PRIM                   51
+#define MUT_PRIM                52
+#define TSO                    53
+#define STACK                   54
+#define TREC_CHUNK              55
+#define ATOMICALLY_FRAME        56
+#define CATCH_RETRY_FRAME       57
+#define CATCH_STM_FRAME         58
+#define WHITEHOLE               59
+#define N_CLOSURE_TYPES         60
 
 #endif /* RTS_STORAGE_CLOSURETYPES_H */
index 5f4f035..fcba1eb 100644 (file)
@@ -240,60 +240,6 @@ typedef struct {
 #define BCO_BITMAP_SIZEW(bco) ((BCO_BITMAP_SIZE(bco) + BITS_IN(StgWord) - 1) \
                                / BITS_IN(StgWord))
 
-/* -----------------------------------------------------------------------------
-   Dynamic stack frames for generic heap checks.
-
-   These generic heap checks are slow, but have the advantage of being
-   usable in a variety of situations.
-
-   The one restriction is that any relevant SRTs must already be pointed
-   to from the stack.  The return address doesn't need to have an info
-   table attached: hence it can be any old code pointer.
-
-   The liveness mask contains a 1 at bit n, if register Rn contains a
-   non-pointer.  The contents of all 8 vanilla registers are always saved
-   on the stack; the liveness mask tells the GC which ones contain
-   pointers.
-
-   Good places to use a generic heap check: 
-
-        - case alternatives (the return address with an SRT is already
-         on the stack).
-
-       - primitives (no SRT required).
-
-   The stack frame layout for a RET_DYN is like this:
-
-          some pointers         |-- RET_DYN_PTRS(liveness) words
-          some nonpointers      |-- RET_DYN_NONPTRS(liveness) words
-                              
-         L1                    \
-          D1-2                  |-- RET_DYN_NONPTR_REGS_SIZE words
-         F1-4                  /
-                              
-         R1-8                  |-- RET_DYN_BITMAP_SIZE words
-                              
-         return address        \
-         liveness mask         |-- StgRetDyn structure
-         stg_gen_chk_info      /
-
-   we assume that the size of a double is always 2 pointers (wasting a
-   word when it is only one pointer, but avoiding lots of #ifdefs).
-
-   See Liveness.h for the macros (RET_DYN_PTRS() etc.).
-
-   NOTE: if you change the layout of RET_DYN stack frames, then you
-   might also need to adjust the value of RESERVED_STACK_WORDS in
-   Constants.h.
-   -------------------------------------------------------------------------- */
-
-typedef struct {
-    const StgInfoTable* info;
-    StgWord        liveness;
-    StgWord        ret_addr;
-    StgClosure *   payload[FLEXIBLE_ARRAY];
-} StgRetDyn;
-
 /* A function return stack frame: used when saving the state for a
  * garbage collection at a function entry point.  The function
  * arguments are on the stack, and we also save the function (its
@@ -430,7 +376,7 @@ typedef struct {
 
 typedef struct {
   StgHeader      header;
-  StgBool        running_alt_code;
+  StgWord        running_alt_code;
   StgClosure    *first_code;
   StgClosure    *alt_code;
 } StgCatchRetryFrame;
diff --git a/includes/rts/storage/Liveness.h b/includes/rts/storage/Liveness.h
deleted file mode 100644 (file)
index 66c82f3..0000000
+++ /dev/null
@@ -1,34 +0,0 @@
-/* -----------------------------------------------------------------------------
- *
- * (c) The University of Glasgow 2004
- *
- * Building liveness masks for RET_DYN stack frames.
- * A few macros that are used in both .cmm and .c sources.
- *
- * A liveness mask is constructed like so:
- *
- *    R1_PTR & R2_PTR & R3_PTR
- *
- * -------------------------------------------------------------------------- */
-
-#ifndef RTS_STORAGE_LIVENESS_H
-#define RTS_STORAGE_LIVENESS_H
-
-#define NO_PTRS   0xff
-#define R1_PTR   (NO_PTRS ^ (1<<0))
-#define R2_PTR   (NO_PTRS ^ (1<<1))
-#define R3_PTR   (NO_PTRS ^ (1<<2))
-#define R4_PTR   (NO_PTRS ^ (1<<3))
-#define R5_PTR   (NO_PTRS ^ (1<<4))
-#define R6_PTR   (NO_PTRS ^ (1<<5))
-#define R7_PTR   (NO_PTRS ^ (1<<6))
-#define R8_PTR   (NO_PTRS ^ (1<<7))
-
-#define N_NONPTRS(n)  ((n)<<16)
-#define N_PTRS(n)     ((n)<<24)
-
-#define RET_DYN_NONPTRS(l) ((l)>>16 & 0xff)
-#define RET_DYN_PTRS(l)    ((l)>>24 & 0xff)
-#define RET_DYN_LIVENESS(l) ((l) & 0xffff)
-
-#endif /* RTS_STORAGE_LIVENESS_H */
index 8dee7cb..cd6a789 100644 (file)
@@ -12,7 +12,7 @@
 #ifdef CMINUSMINUS
 
 #define unlockClosure(ptr,info)                 \
-    prim %write_barrier() [];                   \
+    prim %write_barrier();                      \
     StgHeader_info(ptr) = info;    
 
 #else
index c93cc31..b7b24a8 100644 (file)
@@ -169,23 +169,6 @@ RTS_RET(stg_noforceIO);
 
 /* standard selector thunks */
 
-RTS_RET(stg_sel_ret_0_upd);
-RTS_RET(stg_sel_ret_1_upd);
-RTS_RET(stg_sel_ret_2_upd);
-RTS_RET(stg_sel_ret_3_upd);
-RTS_RET(stg_sel_ret_4_upd);
-RTS_RET(stg_sel_ret_5_upd);
-RTS_RET(stg_sel_ret_6_upd);
-RTS_RET(stg_sel_ret_7_upd);
-RTS_RET(stg_sel_ret_8_upd);
-RTS_RET(stg_sel_ret_9_upd);
-RTS_RET(stg_sel_ret_10_upd);
-RTS_RET(stg_sel_ret_11_upd);
-RTS_RET(stg_sel_ret_12_upd);
-RTS_RET(stg_sel_ret_13_upd);
-RTS_RET(stg_sel_ret_14_upd);
-RTS_RET(stg_sel_ret_15_upd);
-
 RTS_ENTRY(stg_sel_0_upd);
 RTS_ENTRY(stg_sel_1_upd);
 RTS_ENTRY(stg_sel_2_upd);
@@ -267,45 +250,39 @@ RTS_FUN_DECL(stg_PAP_apply);
 
 /* standard GC & stack check entry points, all defined in HeapStackCheck.hc */
 
-RTS_RET(stg_enter);
+RTS_FUN_DECL(stg_gc_noregs);
+
 RTS_RET(stg_enter_checkbh);
 
-RTS_RET(stg_gc_void);
+RTS_RET(stg_ret_v);
+RTS_RET(stg_ret_p);
+RTS_RET(stg_ret_n);
+RTS_RET(stg_ret_f);
+RTS_RET(stg_ret_d);
+RTS_RET(stg_ret_l);
 
+RTS_FUN_DECL(stg_gc_prim_p);
+RTS_FUN_DECL(stg_gc_prim_pp);
+RTS_FUN_DECL(stg_gc_prim_n);
+
+RTS_RET(stg_enter);
 RTS_FUN_DECL(__stg_gc_enter_1);
-RTS_FUN_DECL(stg_gc_noregs);
 
-RTS_RET(stg_gc_unpt_r1);
 RTS_FUN_DECL(stg_gc_unpt_r1);
-
-RTS_RET(stg_gc_unbx_r1);
 RTS_FUN_DECL(stg_gc_unbx_r1);
-
-RTS_RET(stg_gc_f1);
 RTS_FUN_DECL(stg_gc_f1);
-
-RTS_RET(stg_gc_d1);
 RTS_FUN_DECL(stg_gc_d1);
-
-RTS_RET(stg_gc_l1);
 RTS_FUN_DECL(stg_gc_l1);
+RTS_FUN_DECL(stg_gc_pp);
+RTS_FUN_DECL(stg_gc_ppp);
+RTS_FUN_DECL(stg_gc_pppp);
 
 RTS_RET(stg_gc_fun);
 RTS_FUN_DECL(__stg_gc_fun);
 
-RTS_RET(stg_gc_gen);
-RTS_FUN_DECL(stg_gc_gen);
-
-RTS_RET(stg_ut_1_0_unreg);
-
-RTS_FUN_DECL(stg_gc_gen_hp);
-RTS_FUN_DECL(stg_gc_ut);
-RTS_FUN_DECL(stg_gen_yield);
 RTS_FUN_DECL(stg_yield_noregs);
 RTS_FUN_DECL(stg_yield_to_interpreter);
-RTS_FUN_DECL(stg_gen_block);
 RTS_FUN_DECL(stg_block_noregs);
-RTS_FUN_DECL(stg_block_1);
 RTS_FUN_DECL(stg_block_blackhole);
 RTS_FUN_DECL(stg_block_blackhole_finally);
 RTS_FUN_DECL(stg_block_takemvar);
index bf17b7e..70e93d3 100644 (file)
@@ -93,10 +93,10 @@ typedef struct {
 
 /*
  * Registers Hp and HpLim are global across the entire system, and are
- * copied into the RegTable before executing a thread.
+ * copied into the RegTable or registers before executing a thread.
  *
- * Registers Sp and SpLim are saved in the TSO for the
- * thread, but are copied into the RegTable before executing a thread.
+ * Registers Sp and SpLim are saved in the TSO for the thread, but are
+ * copied into the RegTable or registers before executing a thread.
  *
  * All other registers are "general purpose", and are used for passing
  * arguments to functions, and returning values.  The code generator
@@ -116,45 +116,6 @@ typedef struct {
  * (pseudo-)registers in those cases.
  */
 
-/* 
- * Locations for saving per-thread registers.
- */
-
-#define SAVE_Sp            (CurrentTSO->sp)
-#define SAVE_SpLim         (CurrentTSO->splim)
-
-#define SAVE_Hp                    (BaseReg->rHp)
-
-#define SAVE_CurrentTSO     (BaseReg->rCurrentTSO)
-#define SAVE_CurrentNursery (BaseReg->rCurrentNursery)
-#define SAVE_HpAlloc        (BaseReg->rHpAlloc)
-
-/* We sometimes need to save registers across a C-call, eg. if they
- * are clobbered in the standard calling convention.  We define the
- * save locations for all registers in the register table.
- */
-
-#define SAVE_R1             (BaseReg->rR1)
-#define SAVE_R2             (BaseReg->rR2)
-#define SAVE_R3             (BaseReg->rR3)
-#define SAVE_R4             (BaseReg->rR4)
-#define SAVE_R5             (BaseReg->rR5)
-#define SAVE_R6             (BaseReg->rR6)
-#define SAVE_R7             (BaseReg->rR7)
-#define SAVE_R8             (BaseReg->rR8)
-#define SAVE_R9             (BaseReg->rR9)
-#define SAVE_R10            (BaseReg->rR10)
-#define SAVE_F1             (BaseReg->rF1)
-#define SAVE_F2             (BaseReg->rF2)
-#define SAVE_F3             (BaseReg->rF3)
-#define SAVE_F4             (BaseReg->rF4)
-
-#define SAVE_D1             (BaseReg->rD1)
-#define SAVE_D2             (BaseReg->rD2)
-
-#define SAVE_L1             (BaseReg->rL1)
-
 /* -----------------------------------------------------------------------------
  * Emit the GCC-specific register declarations for each machine
  * register being used.  If any STG register isn't mapped to a machine
@@ -163,11 +124,6 @@ typedef struct {
  * First, the general purpose registers.  The idea is, if a particular
  * general-purpose STG register can't be mapped to a real machine
  * register, it won't be used at all.  Instead, we'll use the stack.
- *
- * This is an improvement on the way things used to be done, when all
- * registers were mapped to locations in the register table, and stuff
- * was being shifted from the stack to the register table and back
- * again for no good reason (on register-poor architectures).
  */
 
 /* define NO_REGS to omit register declarations - used in RTS C code
@@ -402,287 +358,6 @@ GLOBAL_REG_DECL(bdescr *,HpAlloc,REG_HpAlloc)
 #define stg_gc_enter_1            (FunReg->stgGCEnter1)
 #define stg_gc_fun                (FunReg->stgGCFun)
 
-/* -----------------------------------------------------------------------------
-   For any registers which are denoted "caller-saves" by the C calling
-   convention, we have to emit code to save and restore them across C
-   calls.
-   -------------------------------------------------------------------------- */
-
-#ifdef CALLER_SAVES_R1
-#define CALLER_SAVE_R1         SAVE_R1 = R1;
-#define CALLER_RESTORE_R1      R1 = SAVE_R1;
-#else
-#define CALLER_SAVE_R1         /* nothing */
-#define CALLER_RESTORE_R1      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R2
-#define CALLER_SAVE_R2         SAVE_R2 = R2;
-#define CALLER_RESTORE_R2      R2 = SAVE_R2;
-#else
-#define CALLER_SAVE_R2         /* nothing */
-#define CALLER_RESTORE_R2      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R3
-#define CALLER_SAVE_R3         SAVE_R3 = R3;
-#define CALLER_RESTORE_R3      R3 = SAVE_R3;
-#else
-#define CALLER_SAVE_R3         /* nothing */
-#define CALLER_RESTORE_R3      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R4
-#define CALLER_SAVE_R4         SAVE_R4 = R4;
-#define CALLER_RESTORE_R4      R4 = SAVE_R4;
-#else
-#define CALLER_SAVE_R4         /* nothing */
-#define CALLER_RESTORE_R4      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R5
-#define CALLER_SAVE_R5         SAVE_R5 = R5;
-#define CALLER_RESTORE_R5      R5 = SAVE_R5;
-#else
-#define CALLER_SAVE_R5         /* nothing */
-#define CALLER_RESTORE_R5      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R6
-#define CALLER_SAVE_R6         SAVE_R6 = R6;
-#define CALLER_RESTORE_R6      R6 = SAVE_R6;
-#else
-#define CALLER_SAVE_R6         /* nothing */
-#define CALLER_RESTORE_R6      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R7
-#define CALLER_SAVE_R7         SAVE_R7 = R7;
-#define CALLER_RESTORE_R7      R7 = SAVE_R7;
-#else
-#define CALLER_SAVE_R7         /* nothing */
-#define CALLER_RESTORE_R7      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R8
-#define CALLER_SAVE_R8         SAVE_R8 = R8;
-#define CALLER_RESTORE_R8      R8 = SAVE_R8;
-#else
-#define CALLER_SAVE_R8         /* nothing */
-#define CALLER_RESTORE_R8      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R9
-#define CALLER_SAVE_R9         SAVE_R9 = R9;
-#define CALLER_RESTORE_R9      R9 = SAVE_R9;
-#else
-#define CALLER_SAVE_R9         /* nothing */
-#define CALLER_RESTORE_R9      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_R10
-#define CALLER_SAVE_R10        SAVE_R10 = R10;
-#define CALLER_RESTORE_R10     R10 = SAVE_R10;
-#else
-#define CALLER_SAVE_R10        /* nothing */
-#define CALLER_RESTORE_R10     /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_F1
-#define CALLER_SAVE_F1         SAVE_F1 = F1;
-#define CALLER_RESTORE_F1      F1 = SAVE_F1;
-#else
-#define CALLER_SAVE_F1         /* nothing */
-#define CALLER_RESTORE_F1      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_F2
-#define CALLER_SAVE_F2         SAVE_F2 = F2;
-#define CALLER_RESTORE_F2      F2 = SAVE_F2;
-#else
-#define CALLER_SAVE_F2         /* nothing */
-#define CALLER_RESTORE_F2      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_F3
-#define CALLER_SAVE_F3         SAVE_F3 = F3;
-#define CALLER_RESTORE_F3      F3 = SAVE_F3;
-#else
-#define CALLER_SAVE_F3         /* nothing */
-#define CALLER_RESTORE_F3      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_F4
-#define CALLER_SAVE_F4         SAVE_F4 = F4;
-#define CALLER_RESTORE_F4      F4 = SAVE_F4;
-#else
-#define CALLER_SAVE_F4         /* nothing */
-#define CALLER_RESTORE_F4      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_D1
-#define CALLER_SAVE_D1         SAVE_D1 = D1;
-#define CALLER_RESTORE_D1      D1 = SAVE_D1;
-#else
-#define CALLER_SAVE_D1         /* nothing */
-#define CALLER_RESTORE_D1      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_D2
-#define CALLER_SAVE_D2         SAVE_D2 = D2;
-#define CALLER_RESTORE_D2      D2 = SAVE_D2;
-#else
-#define CALLER_SAVE_D2         /* nothing */
-#define CALLER_RESTORE_D2      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_L1
-#define CALLER_SAVE_L1         SAVE_L1 = L1;
-#define CALLER_RESTORE_L1      L1 = SAVE_L1;
-#else
-#define CALLER_SAVE_L1         /* nothing */
-#define CALLER_RESTORE_L1      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_Sp
-#define CALLER_SAVE_Sp         SAVE_Sp = Sp;
-#define CALLER_RESTORE_Sp      Sp = SAVE_Sp;
-#else
-#define CALLER_SAVE_Sp         /* nothing */
-#define CALLER_RESTORE_Sp      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_SpLim
-#define CALLER_SAVE_SpLim      SAVE_SpLim = SpLim;
-#define CALLER_RESTORE_SpLim   SpLim = SAVE_SpLim;
-#else
-#define CALLER_SAVE_SpLim      /* nothing */
-#define CALLER_RESTORE_SpLim   /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_Hp
-#define CALLER_SAVE_Hp         SAVE_Hp = Hp;
-#define CALLER_RESTORE_Hp      Hp = SAVE_Hp;
-#else
-#define CALLER_SAVE_Hp         /* nothing */
-#define CALLER_RESTORE_Hp      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_Base
-#ifdef THREADED_RTS
-#error "Can't have caller-saved BaseReg with THREADED_RTS"
-#endif
-#define CALLER_SAVE_Base       /* nothing */
-#define CALLER_RESTORE_Base    BaseReg = &MainRegTable;
-#else
-#define CALLER_SAVE_Base       /* nothing */
-#define CALLER_RESTORE_Base    /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_CurrentTSO
-#define CALLER_SAVE_CurrentTSO         SAVE_CurrentTSO = CurrentTSO;
-#define CALLER_RESTORE_CurrentTSO      CurrentTSO = SAVE_CurrentTSO;
-#else
-#define CALLER_SAVE_CurrentTSO         /* nothing */
-#define CALLER_RESTORE_CurrentTSO      /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_CurrentNursery
-#define CALLER_SAVE_CurrentNursery     SAVE_CurrentNursery = CurrentNursery;
-#define CALLER_RESTORE_CurrentNursery  CurrentNursery = SAVE_CurrentNursery;
-#else
-#define CALLER_SAVE_CurrentNursery     /* nothing */
-#define CALLER_RESTORE_CurrentNursery   /* nothing */
-#endif
-
-#ifdef CALLER_SAVES_HpAlloc
-#define CALLER_SAVE_HpAlloc            SAVE_HpAlloc = HpAlloc;
-#define CALLER_RESTORE_HpAlloc         HpAlloc = SAVE_HpAlloc;
-#else
-#define CALLER_SAVE_HpAlloc            /* nothing */
-#define CALLER_RESTORE_HpAlloc         /* nothing */
-#endif
-
 #endif /* IN_STG_CODE */
 
-/* ----------------------------------------------------------------------------
-   Handy bunches of saves/restores 
-   ------------------------------------------------------------------------  */
-
-#if IN_STG_CODE
-
-#define CALLER_SAVE_USER                       \
-  CALLER_SAVE_R1                               \
-  CALLER_SAVE_R2                               \
-  CALLER_SAVE_R3                               \
-  CALLER_SAVE_R4                               \
-  CALLER_SAVE_R5                               \
-  CALLER_SAVE_R6                               \
-  CALLER_SAVE_R7                               \
-  CALLER_SAVE_R8                               \
-  CALLER_SAVE_R9                               \
-  CALLER_SAVE_R10                              \
-  CALLER_SAVE_F1                               \
-  CALLER_SAVE_F2                               \
-  CALLER_SAVE_F3                               \
-  CALLER_SAVE_F4                               \
-  CALLER_SAVE_D1                               \
-  CALLER_SAVE_D2                               \
-  CALLER_SAVE_L1
-
-     /* Save Base last, since the others may
-       be addressed relative to it */
-#define CALLER_SAVE_SYSTEM                     \
-  CALLER_SAVE_Sp                               \
-  CALLER_SAVE_SpLim                            \
-  CALLER_SAVE_Hp                               \
-  CALLER_SAVE_CurrentTSO                       \
-  CALLER_SAVE_CurrentNursery                   \
-  CALLER_SAVE_Base
-
-#define CALLER_RESTORE_USER                    \
-  CALLER_RESTORE_R1                            \
-  CALLER_RESTORE_R2                            \
-  CALLER_RESTORE_R3                            \
-  CALLER_RESTORE_R4                            \
-  CALLER_RESTORE_R5                            \
-  CALLER_RESTORE_R6                            \
-  CALLER_RESTORE_R7                            \
-  CALLER_RESTORE_R8                            \
-  CALLER_RESTORE_R9                            \
-  CALLER_RESTORE_R10                   \
-  CALLER_RESTORE_F1                            \
-  CALLER_RESTORE_F2                            \
-  CALLER_RESTORE_F3                            \
-  CALLER_RESTORE_F4                            \
-  CALLER_RESTORE_D1                            \
-  CALLER_RESTORE_D2                            \
-  CALLER_RESTORE_L1
-
-     /* Restore Base first, since the others may
-       be addressed relative to it */
-#define CALLER_RESTORE_SYSTEM                  \
-  CALLER_RESTORE_Base                          \
-  CALLER_RESTORE_Sp                            \
-  CALLER_RESTORE_SpLim                         \
-  CALLER_RESTORE_Hp                            \
-  CALLER_RESTORE_CurrentTSO                    \
-  CALLER_RESTORE_CurrentNursery
-
-#else /* not IN_STG_CODE */
-
-#define CALLER_SAVE_USER       /* nothing */
-#define CALLER_SAVE_SYSTEM     /* nothing */
-#define CALLER_RESTORE_USER    /* nothing */
-#define CALLER_RESTORE_SYSTEM  /* nothing */
-
-#endif /* IN_STG_CODE */
-#define CALLER_SAVE_ALL                                \
-  CALLER_SAVE_SYSTEM                           \
-  CALLER_SAVE_USER
-
-#define CALLER_RESTORE_ALL                     \
-  CALLER_RESTORE_SYSTEM                                \
-  CALLER_RESTORE_USER
-
 #endif /* REGS_H */
index a2d4a7e..b89abea 100644 (file)
 
 STRING(stg_ap_0_ret_str,"stg_ap_0_ret... ")
 
-stg_ap_0_fast
+stg_ap_0_fast ( P_ fun )
 { 
-    // fn is in R1, no args on the stack
-
     IF_DEBUG(apply,
-       foreign "C" debugBelch(stg_ap_0_ret_str) [R1];
-       foreign "C" printClosure(R1 "ptr") [R1]);
+        ccall debugBelch(stg_ap_0_ret_str);
+        ccall printClosure(R1 "ptr"));
 
     IF_DEBUG(sanity,
-       foreign "C" checkStackFrame(Sp "ptr") [R1]);
+        ccall checkStackFrame(Sp "ptr"));
 
-    ENTER();
+    ENTER(fun);
 }
 
 /* -----------------------------------------------------------------------------
@@ -56,9 +54,9 @@ stg_ap_0_fast
    -------------------------------------------------------------------------- */
 
 INFO_TABLE(stg_PAP,/*special layout*/0,0,PAP,"PAP","PAP")
-{  foreign "C" barf("PAP object entered!") never returns; }
+{  ccall barf("PAP object entered!") never returns; }
     
-stg_PAP_apply
+stg_PAP_apply /* no args => explicit stack */
 {
   W_ Words;
   W_ pap;
@@ -78,7 +76,7 @@ stg_PAP_apply
       // this before calling stg_PAP_entry.
       Sp_adj(-1); 
       Sp(0) = R2;
-      jump stg_gc_unpt_r1;
+      jump stg_gc_unpt_r1 [R1];
   }
   Sp_adj(-Words);
 
@@ -86,7 +84,7 @@ stg_PAP_apply
   TICK_ENT_PAP();
   LDV_ENTER(pap);
 #ifdef PROFILING
-  foreign "C" enterFunCCS(BaseReg "ptr", StgHeader_ccs(pap) "ptr");
+  ccall enterFunCCS(BaseReg "ptr", StgHeader_ccs(pap) "ptr");
 #endif
 
   // Reload the stack 
@@ -122,26 +120,26 @@ for:
   TICK_ENT_VIA_NODE();
 
 #ifdef NO_ARG_REGS
-  jump %GET_ENTRY(UNTAG(R1));
+  jump %GET_ENTRY(UNTAG(R1)) [R1];
 #else
       W_ info;
       info = %GET_FUN_INFO(UNTAG(R1));
       W_ type;
       type = TO_W_(StgFunInfoExtra_fun_type(info));
       if (type == ARG_GEN) {
-         jump StgFunInfoExtra_slow_apply(info);
+          jump StgFunInfoExtra_slow_apply(info) [R1];
       }
       if (type == ARG_GEN_BIG) {
-         jump StgFunInfoExtra_slow_apply(info);
+          jump StgFunInfoExtra_slow_apply(info) [R1];
       }
       if (type == ARG_BCO) {
          Sp_adj(-2);
          Sp(1) = R1;
          Sp(0) = stg_apply_interp_info;
-         jump stg_yield_to_interpreter;
+          jump stg_yield_to_interpreter [];
       }
       jump W_[stg_ap_stack_entries + 
-               WDS(TO_W_(StgFunInfoExtra_fun_type(info)))];
+                WDS(TO_W_(StgFunInfoExtra_fun_type(info)))] [R1];
 #endif
 }
 
@@ -155,6 +153,7 @@ for:
    -------------------------------------------------------------------------- */
 
 INFO_TABLE(stg_AP,/*special layout*/0,0,AP,"AP","AP")
+ /* no args => explicit stack */
 {
   W_ Words;
   W_ ap;
@@ -164,12 +163,12 @@ INFO_TABLE(stg_AP,/*special layout*/0,0,AP,"AP","AP")
   Words = TO_W_(StgAP_n_args(ap));
 
   /* 
-   * Check for stack overflow.  IMPORTANT: use a _NP check here,
+   * Check for stack overflow.  IMPORTANT: use a _ENTER check here,
    * because if the check fails, we might end up blackholing this very
    * closure, in which case we must enter the blackhole on return rather
    * than continuing to evaluate the now-defunct closure.
    */
-  STK_CHK_NP(WDS(Words) + SIZEOF_StgUpdateFrame);
+  STK_CHK_ENTER(WDS(Words) + SIZEOF_StgUpdateFrame, R1);
 
   PUSH_UPD_FRAME(Sp - SIZEOF_StgUpdateFrame, R1);
   Sp = Sp - SIZEOF_StgUpdateFrame - WDS(Words);
@@ -197,26 +196,26 @@ for:
   TICK_ENT_VIA_NODE();
 
 #ifdef NO_ARG_REGS
-  jump %GET_ENTRY(UNTAG(R1));
+  jump %GET_ENTRY(UNTAG(R1)) [R1];
 #else
       W_ info;
       info = %GET_FUN_INFO(UNTAG(R1));
       W_ type;
       type = TO_W_(StgFunInfoExtra_fun_type(info));
       if (type == ARG_GEN) {
-         jump StgFunInfoExtra_slow_apply(info);
+          jump StgFunInfoExtra_slow_apply(info) [R1];
       }
       if (type == ARG_GEN_BIG) {
-         jump StgFunInfoExtra_slow_apply(info);
+          jump StgFunInfoExtra_slow_apply(info) [R1];
       }
       if (type == ARG_BCO) {
          Sp_adj(-2);
          Sp(1) = R1;
          Sp(0) = stg_apply_interp_info;
-         jump stg_yield_to_interpreter;
+          jump stg_yield_to_interpreter [];
       }
       jump W_[stg_ap_stack_entries + 
-               WDS(TO_W_(StgFunInfoExtra_fun_type(info)))];
+                WDS(TO_W_(StgFunInfoExtra_fun_type(info)))] [R1];
 #endif
 }
 
@@ -225,6 +224,7 @@ for:
    those generated by the byte-code compiler for inserting breakpoints. */
 
 INFO_TABLE(stg_AP_NOUPD,/*special layout*/0,0,AP,"AP_NOUPD","AP_NOUPD")
+   /* no args => explicit stack */
 {
   W_ Words;
   W_ ap;
@@ -234,12 +234,12 @@ INFO_TABLE(stg_AP_NOUPD,/*special layout*/0,0,AP,"AP_NOUPD","AP_NOUPD")
   Words = TO_W_(StgAP_n_args(ap));
 
   /* 
-   * Check for stack overflow.  IMPORTANT: use a _NP check here,
+   * Check for stack overflow.  IMPORTANT: use a _ENTER check here,
    * because if the check fails, we might end up blackholing this very
    * closure, in which case we must enter the blackhole on return rather
    * than continuing to evaluate the now-defunct closure.
    */
-  STK_CHK_NP(WDS(Words));
+  STK_CHK_ENTER(WDS(Words), R1);
   Sp = Sp - WDS(Words);
 
   TICK_ENT_AP();
@@ -265,26 +265,26 @@ for:
   TICK_ENT_VIA_NODE();
 
 #ifdef NO_ARG_REGS
-  jump %GET_ENTRY(UNTAG(R1));
+  jump %GET_ENTRY(UNTAG(R1)) [R1];
 #else
       W_ info;
       info = %GET_FUN_INFO(UNTAG(R1));
       W_ type;
       type = TO_W_(StgFunInfoExtra_fun_type(info));
       if (type == ARG_GEN) {
-         jump StgFunInfoExtra_slow_apply(info);
+          jump StgFunInfoExtra_slow_apply(info) [R1];
       }
       if (type == ARG_GEN_BIG) {
-         jump StgFunInfoExtra_slow_apply(info);
+          jump StgFunInfoExtra_slow_apply(info) [R1];
       }
       if (type == ARG_BCO) {
          Sp_adj(-2);
          Sp(1) = R1;
          Sp(0) = stg_apply_interp_info;
-         jump stg_yield_to_interpreter;
+          jump stg_yield_to_interpreter [];
       }
       jump W_[stg_ap_stack_entries + 
-               WDS(TO_W_(StgFunInfoExtra_fun_type(info)))];
+                WDS(TO_W_(StgFunInfoExtra_fun_type(info)))] [R1];
 #endif
 }
 
@@ -300,6 +300,7 @@ for:
    -------------------------------------------------------------------------- */
 
 INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK")
+  /* no args => explicit stack */
 {
   W_ Words;
   W_ ap;
@@ -309,12 +310,12 @@ INFO_TABLE(stg_AP_STACK,/*special layout*/0,0,AP_STACK,"AP_STACK","AP_STACK")
   Words = StgAP_STACK_size(ap);
 
   /* 
-   * Check for stack overflow.  IMPORTANT: use a _NP check here,
+   * Check for stack overflow.  IMPORTANT: use a _ENTER check here,
    * because if the check fails, we might end up blackholing this very
    * closure, in which case we must enter the blackhole on return rather
    * than continuing to evaluate the now-defunct closure.
    */
-  STK_CHK_NP(WDS(Words) + SIZEOF_StgUpdateFrame + WDS(AP_STACK_SPLIM));
+  STK_CHK_ENTER(WDS(Words) + SIZEOF_StgUpdateFrame + WDS(AP_STACK_SPLIM), R1);
   /* ensure there is at least AP_STACK_SPLIM words of headroom available
    * after unpacking the AP_STACK. See bug #1466 */
 
@@ -343,7 +344,7 @@ for:
 
   R1 = StgAP_STACK_fun(ap);
 
-  ENTER();
+  ENTER_R1();
 }
 
 /* -----------------------------------------------------------------------------
@@ -352,6 +353,7 @@ for:
 
 INFO_TABLE(stg_AP_STACK_NOUPD,/*special layout*/0,0,AP_STACK,
                                         "AP_STACK_NOUPD","AP_STACK_NOUPD")
+   /* no args => explicit stack */
 {
   W_ Words;
   W_ ap;
@@ -366,7 +368,7 @@ INFO_TABLE(stg_AP_STACK_NOUPD,/*special layout*/0,0,AP_STACK,
    * closure, in which case we must enter the blackhole on return rather
    * than continuing to evaluate the now-defunct closure.
    */
-  STK_CHK_NP(WDS(Words) + WDS(AP_STACK_SPLIM));
+  STK_CHK_ENTER(WDS(Words) + WDS(AP_STACK_SPLIM), R1);
   /* ensure there is at least AP_STACK_SPLIM words of headroom available
    * after unpacking the AP_STACK. See bug #1466 */
 
@@ -394,5 +396,5 @@ for:
 
   R1 = StgAP_STACK_fun(ap);
 
-  ENTER();
+  ENTER_R1();
 }
index d0c5c3f..ebb7308 100644 (file)
@@ -35,7 +35,7 @@
     }                                                  \
     R1 = pap;                                          \
     Sp_adj(1 + n);                                     \
-    jump %ENTRY_CODE(Sp(0));
+    jump %ENTRY_CODE(Sp(0)) [R1];
 
 // Copy the old PAP, build a new one with the extra arg(s)
 // ret addr and m arguments taking up n words are on the stack.
@@ -74,7 +74,7 @@
      }                                                         \
      R1 = new_pap;                                             \
      Sp_adj(n+1);                                              \
-     jump %ENTRY_CODE(Sp(0));
+     jump %ENTRY_CODE(Sp(0)) [R1];
 
 // Jump to target, saving CCCS and restoring it on return
 #if defined(PROFILING)
@@ -82,9 +82,9 @@
     Sp(-1) = CCCS;                              \
     Sp(-2) = stg_restore_cccs_info;             \
     Sp_adj(-2);                                 \
-    jump (target)
+    jump (target) [*]
 #else
-#define jump_SAVE_CCCS(target) jump (target)
+#define jump_SAVE_CCCS(target) jump (target) [*]
 #endif
 
 #endif /* APPLY_H */
index 0ab8b45..a2a1402 100644 (file)
@@ -55,8 +55,7 @@ StgWord16 closure_flags[] = {
  [RET_BCO]              =  ( 0                                         ),
  [RET_SMALL]           =  (     _BTM|                       _SRT      ),
  [RET_BIG]             =  (                                 _SRT      ),
- [RET_DYN]             =  (                                 _SRT      ),
- [RET_FUN]             =  ( 0                                         ),
+ [RET_FUN]              =  ( 0                                         ),
  [UPDATE_FRAME]                =  (     _BTM                                  ),
  [CATCH_FRAME]         =  (     _BTM                                  ),
  [UNDERFLOW_FRAME]      =  (     _BTM                                  ),
@@ -84,6 +83,6 @@ StgWord16 closure_flags[] = {
  [WHITEHOLE]           =  ( 0                                         )
 };
 
-#if N_CLOSURE_TYPES != 61
+#if N_CLOSURE_TYPES != 60
 #error Closure types changed: update ClosureFlags.c!
 #endif
index 78907c4..8a9f4e6 100644 (file)
@@ -50,7 +50,8 @@ import ghczmprim_GHCziTypes_True_closure;
    -------------------------------------------------------------------------- */
 
 
-INFO_TABLE_RET(stg_unmaskAsyncExceptionszh_ret, RET_SMALL)
+INFO_TABLE_RET(stg_unmaskAsyncExceptionszh_ret, RET_SMALL, W_ info_ptr)
+    /* explicit stack */
 {
     CInt r;
 
@@ -60,7 +61,7 @@ INFO_TABLE_RET(stg_unmaskAsyncExceptionszh_ret, RET_SMALL)
     /* Eagerly raise a blocked exception, if there is one */
     if (StgTSO_blocked_exceptions(CurrentTSO) != END_TSO_QUEUE) {
 
-        STK_CHK_GEN( WDS(2), R1_PTR, stg_unmaskAsyncExceptionszh_ret_info);
+        STK_CHK_P (WDS(2), stg_unmaskAsyncExceptionszh_ret_info, R1);
         /* 
          * We have to be very careful here, as in killThread#, since
          * we are about to raise an async exception in the current
@@ -68,18 +69,18 @@ INFO_TABLE_RET(stg_unmaskAsyncExceptionszh_ret, RET_SMALL)
          */
         Sp_adj(-2);
         Sp(1) = R1;
-        Sp(0) = stg_gc_unpt_r1_info;
+        Sp(0) = stg_ret_p_info;
         SAVE_THREAD_STATE();
-        (r) = foreign "C" maybePerformBlockedException (MyCapability() "ptr", 
-                                                     CurrentTSO "ptr") [R1];
+        (r) = ccall maybePerformBlockedException (MyCapability() "ptr", 
+                                                      CurrentTSO "ptr");
 
         if (r != 0::CInt) {
             if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
-                jump stg_threadFinished;
+                jump stg_threadFinished [];
             } else {
                 LOAD_THREAD_STATE();
                 ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
-                jump %ENTRY_CODE(Sp(0));
+                jump %ENTRY_CODE(Sp(0)) [R1];
             }
         }
         else {
@@ -93,10 +94,11 @@ INFO_TABLE_RET(stg_unmaskAsyncExceptionszh_ret, RET_SMALL)
     }
 
     Sp_adj(1);
-    jump %ENTRY_CODE(Sp(0));
+    jump %ENTRY_CODE(Sp(0)) [R1];
 }
 
-INFO_TABLE_RET(stg_maskAsyncExceptionszh_ret, RET_SMALL)
+INFO_TABLE_RET(stg_maskAsyncExceptionszh_ret, RET_SMALL, W_ info_ptr)
+    return (P_ ret)
 {
     StgTSO_flags(CurrentTSO) = 
        %lobits32(
@@ -104,11 +106,11 @@ INFO_TABLE_RET(stg_maskAsyncExceptionszh_ret, RET_SMALL)
           | TSO_BLOCKEX | TSO_INTERRUPTIBLE
       );
 
-    Sp_adj(1);
-    jump %ENTRY_CODE(Sp(0));
+    return (ret);
 }
 
-INFO_TABLE_RET(stg_maskUninterruptiblezh_ret, RET_SMALL)
+INFO_TABLE_RET(stg_maskUninterruptiblezh_ret, RET_SMALL, W_ info_ptr)
+    return (P_ ret)
 {
     StgTSO_flags(CurrentTSO) = 
        %lobits32(
@@ -117,14 +119,13 @@ INFO_TABLE_RET(stg_maskUninterruptiblezh_ret, RET_SMALL)
           & ~TSO_INTERRUPTIBLE
        );
 
-    Sp_adj(1);
-    jump %ENTRY_CODE(Sp(0));
+    return (ret);
 }
 
-stg_maskAsyncExceptionszh
+stg_maskAsyncExceptionszh /* explicit stack */
 {
     /* Args: R1 :: IO a */
-    STK_CHK_GEN( WDS(1)/* worst case */, R1_PTR, stg_maskAsyncExceptionszh);
+    STK_CHK_P( WDS(1)/* worst case */, stg_maskAsyncExceptionszh, R1);
 
     if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) == 0) {
         /* avoid growing the stack unnecessarily */
@@ -146,13 +147,13 @@ stg_maskAsyncExceptionszh
 
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();
-    jump stg_ap_v_fast;
+    jump stg_ap_v_fast [R1];
 }
 
-stg_maskUninterruptiblezh
+stg_maskUninterruptiblezh /* explicit stack */
 {
     /* Args: R1 :: IO a */
-    STK_CHK_GEN( WDS(1)/* worst case */, R1_PTR, stg_maskAsyncExceptionszh);
+    STK_CHK_P( WDS(1)/* worst case */, stg_maskAsyncExceptionszh, R1);
 
     if ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) == 0) {
         /* avoid growing the stack unnecessarily */
@@ -174,16 +175,16 @@ stg_maskUninterruptiblezh
 
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();
-    jump stg_ap_v_fast;
+    jump stg_ap_v_fast [R1];
 }
 
-stg_unmaskAsyncExceptionszh
+stg_unmaskAsyncExceptionszh /* explicit stack */
 {
     CInt r;
     W_ level;
 
     /* Args: R1 :: IO a */
-    STK_CHK_GEN( WDS(4), R1_PTR, stg_unmaskAsyncExceptionszh);
+    STK_CHK_P (WDS(4), stg_unmaskAsyncExceptionszh, R1);
     /* 4 words: one for the unblock frame, 3 for setting up the
      * stack to call maybePerformBlockedException() below.
      */
@@ -225,16 +226,16 @@ stg_unmaskAsyncExceptionszh
             Sp(0) = stg_enter_info;
 
             SAVE_THREAD_STATE();
-            (r) = foreign "C" maybePerformBlockedException (MyCapability() "ptr", 
-                                                     CurrentTSO "ptr") [R1];
+            (r) = ccall maybePerformBlockedException (MyCapability() "ptr", 
+                                                      CurrentTSO "ptr");
 
             if (r != 0::CInt) {
                 if (StgTSO_what_next(CurrentTSO) == ThreadKilled::I16) {
-                    jump stg_threadFinished;
+                    jump stg_threadFinished [];
                } else {
                    LOAD_THREAD_STATE();
                    ASSERT(StgTSO_what_next(CurrentTSO) == ThreadRunGHC::I16);
-                   jump %ENTRY_CODE(Sp(0));
+                    jump %ENTRY_CODE(Sp(0)) [R1];
                }
             } else {
                 /* we'll just call R1 directly, below */
@@ -245,11 +246,11 @@ stg_unmaskAsyncExceptionszh
     }
     TICK_UNKNOWN_CALL();
     TICK_SLOW_CALL_v();
-    jump stg_ap_v_fast;
+    jump stg_ap_v_fast [R1];
 }
 
 
-stg_getMaskingStatezh
+stg_getMaskingStatezh ()
 {
     /* args: none */
     /* 
@@ -257,25 +258,18 @@ stg_getMaskingStatezh
                 1 == masked, non-interruptible,
                 2 == masked, interruptible
     */
-    RET_N(((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_BLOCKEX) != 0) +
-          ((TO_W_(StgTSO_flags(CurrentTSO)) & TSO_INTERRUPTIBLE) != 0)