Commit a7c0387d authored by Simon Marlow's avatar Simon Marlow

Produce new-style Cmm from the Cmm parser

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.
parent aed37acd
...@@ -72,7 +72,7 @@ module CLabel ( ...@@ -72,7 +72,7 @@ module CLabel (
mkCmmRetLabel, mkCmmRetLabel,
mkCmmCodeLabel, mkCmmCodeLabel,
mkCmmDataLabel, mkCmmDataLabel,
mkCmmGcPtrLabel, mkCmmClosureLabel,
mkRtsApFastLabel, mkRtsApFastLabel,
...@@ -331,7 +331,7 @@ data CmmLabelInfo ...@@ -331,7 +331,7 @@ data CmmLabelInfo
| CmmRet -- ^ misc rts return points, suffix _ret | CmmRet -- ^ misc rts return points, suffix _ret
| CmmData -- ^ misc rts data bits, eg CHARLIKE_closure | CmmData -- ^ misc rts data bits, eg CHARLIKE_closure
| CmmCode -- ^ misc rts code | CmmCode -- ^ misc rts code
| CmmGcPtr -- ^ GcPtrs eg CHARLIKE_closure | CmmClosure -- ^ closures eg CHARLIKE_closure
| CmmPrimCall -- ^ a prim call to some hand written Cmm code | CmmPrimCall -- ^ a prim call to some hand written Cmm code
deriving (Eq, Ord) deriving (Eq, Ord)
...@@ -418,7 +418,7 @@ mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOL ...@@ -418,7 +418,7 @@ mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOL
----- -----
mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel,
mkCmmCodeLabel, mkCmmDataLabel, mkCmmGcPtrLabel mkCmmCodeLabel, mkCmmDataLabel, mkCmmClosureLabel
:: PackageId -> FastString -> CLabel :: PackageId -> FastString -> CLabel
mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo mkCmmInfoLabel pkg str = CmmLabel pkg str CmmInfo
...@@ -427,7 +427,7 @@ mkCmmRetInfoLabel pkg str = CmmLabel pkg str CmmRetInfo ...@@ -427,7 +427,7 @@ mkCmmRetInfoLabel pkg str = CmmLabel pkg str CmmRetInfo
mkCmmRetLabel pkg str = CmmLabel pkg str CmmRet mkCmmRetLabel pkg str = CmmLabel pkg str CmmRet
mkCmmCodeLabel pkg str = CmmLabel pkg str CmmCode mkCmmCodeLabel pkg str = CmmLabel pkg str CmmCode
mkCmmDataLabel pkg str = CmmLabel pkg str CmmData mkCmmDataLabel pkg str = CmmLabel pkg str CmmData
mkCmmGcPtrLabel pkg str = CmmLabel pkg str CmmGcPtr mkCmmClosureLabel pkg str = CmmLabel pkg str CmmClosure
-- Constructing RtsLabels -- Constructing RtsLabels
...@@ -543,6 +543,7 @@ mkPlainModuleInitLabel mod = PlainModuleInitLabel mod ...@@ -543,6 +543,7 @@ mkPlainModuleInitLabel mod = PlainModuleInitLabel mod
toClosureLbl :: CLabel -> CLabel toClosureLbl :: CLabel -> CLabel
toClosureLbl (IdLabel n c _) = IdLabel n c Closure toClosureLbl (IdLabel n c _) = IdLabel n c Closure
toClosureLbl (CmmLabel m str _) = CmmLabel m str CmmClosure
toClosureLbl l = pprPanic "toClosureLbl" (ppr l) toClosureLbl l = pprPanic "toClosureLbl" (ppr l)
toSlowEntryLbl :: CLabel -> CLabel toSlowEntryLbl :: CLabel -> CLabel
...@@ -774,7 +775,7 @@ isGcPtrLabel lbl = case labelType lbl of ...@@ -774,7 +775,7 @@ isGcPtrLabel lbl = case labelType lbl of
-- whether it be code, data, or static GC object. -- whether it be code, data, or static GC object.
labelType :: CLabel -> CLabelType labelType :: CLabel -> CLabelType
labelType (CmmLabel _ _ CmmData) = DataLabel labelType (CmmLabel _ _ CmmData) = DataLabel
labelType (CmmLabel _ _ CmmGcPtr) = GcPtrLabel labelType (CmmLabel _ _ CmmClosure) = GcPtrLabel
labelType (CmmLabel _ _ CmmCode) = CodeLabel labelType (CmmLabel _ _ CmmCode) = CodeLabel
labelType (CmmLabel _ _ CmmInfo) = DataLabel labelType (CmmLabel _ _ CmmInfo) = DataLabel
labelType (CmmLabel _ _ CmmEntry) = CodeLabel labelType (CmmLabel _ _ CmmEntry) = CodeLabel
...@@ -1001,7 +1002,6 @@ pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLi ...@@ -1001,7 +1002,6 @@ pprCLbl (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext (sLi
pprCLbl (CmmLabel _ str CmmCode) = ftext str pprCLbl (CmmLabel _ str CmmCode) = ftext str
pprCLbl (CmmLabel _ str CmmData) = ftext str pprCLbl (CmmLabel _ str CmmData) = ftext str
pprCLbl (CmmLabel _ str CmmGcPtr) = ftext str
pprCLbl (CmmLabel _ str CmmPrimCall) = ftext str pprCLbl (CmmLabel _ str CmmPrimCall) = ftext str
pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> ptext (sLit "_fast") pprCLbl (RtsLabel (RtsApFast str)) = ftext str <> ptext (sLit "_fast")
...@@ -1046,6 +1046,9 @@ pprCLbl (CmmLabel _ fs CmmRetInfo) ...@@ -1046,6 +1046,9 @@ pprCLbl (CmmLabel _ fs CmmRetInfo)
pprCLbl (CmmLabel _ fs CmmRet) pprCLbl (CmmLabel _ fs CmmRet)
= ftext fs <> ptext (sLit "_ret") = ftext fs <> ptext (sLit "_ret")
pprCLbl (CmmLabel _ fs CmmClosure)
= ftext fs <> ptext (sLit "_closure")
pprCLbl (RtsLabel (RtsPrimOp primop)) pprCLbl (RtsLabel (RtsPrimOp primop))
= ptext (sLit "stg_") <> ppr primop = ptext (sLit "stg_") <> ppr primop
......
...@@ -109,9 +109,14 @@ data CmmStackInfo ...@@ -109,9 +109,14 @@ data CmmStackInfo
-- number of bytes of arguments on the stack on entry to the -- number of bytes of arguments on the stack on entry to the
-- the proc. This is filled in by StgCmm.codeGen, and used -- the proc. This is filled in by StgCmm.codeGen, and used
-- by the stack allocator later. -- by the stack allocator later.
updfr_space :: Maybe ByteOff updfr_space :: Maybe ByteOff,
-- XXX: this never contains anything useful, but it should. -- XXX: this never contains anything useful, but it should.
-- See comment in CmmLayoutStack. -- 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 -- | Info table as a haskell data type
......
...@@ -235,8 +235,8 @@ to_SRT dflags top_srt off len bmp ...@@ -235,8 +235,8 @@ to_SRT dflags top_srt off len bmp
tbl = CmmData RelocatableReadOnlyData $ tbl = CmmData RelocatableReadOnlyData $
Statics srt_desc_lbl $ map CmmStaticLit Statics srt_desc_lbl $ map CmmStaticLit
( cmmLabelOffW dflags top_srt off ( cmmLabelOffW dflags top_srt off
: mkWordCLit dflags (toStgWord dflags (fromIntegral len)) : mkWordCLit dflags (fromIntegral len)
: map (mkWordCLit dflags) bmp) : map (mkStgWordCLit dflags) bmp)
return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags)) return (Just tbl, C_SRT srt_desc_lbl 0 (srtEscape dflags))
| otherwise | otherwise
= return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp)))) = return (Nothing, C_SRT top_srt off (toStgHalfWord dflags (fromStgWord (head bmp))))
...@@ -252,7 +252,8 @@ localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel) ...@@ -252,7 +252,8 @@ localCAFInfo :: CAFEnv -> CmmDecl -> (CAFSet, Maybe CLabel)
localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing) localCAFInfo _ (CmmData _ _) = (Set.empty, Nothing)
localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) = localCAFInfo cafEnv proc@(CmmProc _ top_l (CmmGraph {g_entry=entry})) =
case topInfoTable proc of 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)) -> (cafs, Just (toClosureLbl top_l))
_other -> (cafs, Nothing) _other -> (cafs, Nothing)
where where
......
...@@ -8,7 +8,8 @@ ...@@ -8,7 +8,8 @@
module CmmCallConv ( module CmmCallConv (
ParamLocation(..), ParamLocation(..),
assignArgumentsPos, assignArgumentsPos,
globalArgRegs assignStack,
globalArgRegs, realArgRegs
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -18,7 +19,6 @@ import SMRep ...@@ -18,7 +19,6 @@ import SMRep
import Cmm (Convention(..)) import Cmm (Convention(..))
import PprCmm () import PprCmm ()
import qualified Data.List as L
import DynFlags import DynFlags
import Outputable import Outputable
...@@ -33,15 +33,22 @@ instance Outputable ParamLocation where ...@@ -33,15 +33,22 @@ instance Outputable ParamLocation where
ppr (RegisterParam g) = ppr g ppr (RegisterParam g) = ppr g
ppr (StackParam p) = ppr p 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, -- Given a list of arguments, and a function that tells their types,
-- return a list showing where each argument is passed -- 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 regs = case (reps, conv) of
(_, NativeNodeCall) -> getRegsWithNode dflags (_, NativeNodeCall) -> getRegsWithNode dflags
(_, NativeDirectCall) -> getRegsWithoutNode dflags (_, NativeDirectCall) -> getRegsWithoutNode dflags
...@@ -49,23 +56,14 @@ assignArgumentsPos dflags conv arg_ty reps = assignments ...@@ -49,23 +56,14 @@ assignArgumentsPos dflags conv arg_ty reps = assignments
(_, NativeReturn) -> getRegsWithNode dflags (_, NativeReturn) -> getRegsWithNode dflags
-- GC calling convention *must* put values in registers -- GC calling convention *must* put values in registers
(_, GC) -> allRegs dflags (_, GC) -> allRegs dflags
(_, PrimOpCall) -> allRegs dflags
([_], PrimOpReturn) -> allRegs dflags
(_, PrimOpReturn) -> getRegsWithNode dflags
(_, Slow) -> noRegs (_, Slow) -> noRegs
-- The calling conventions first assign arguments to registers, -- The calling conventions first assign arguments to registers,
-- then switch to the stack when we first run out of 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). -- (even if there are still available registers for args of a
-- When returning an unboxed tuple, we also separate the stack -- different type). When returning an unboxed tuple, we also
-- arguments by pointerhood. -- separate the stack arguments by pointerhood.
(reg_assts, stk_args) = assign_regs [] reps regs (reg_assts, stk_args) = assign_regs [] reps regs
stk_args' = case conv of NativeReturn -> part (stk_off, stk_assts) = assignStack dflags off arg_ty stk_args
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')
assignments = reg_assts ++ stk_assts assignments = reg_assts ++ stk_assts
assign_regs assts [] _ = (assts, []) assign_regs assts [] _ = (assts, [])
...@@ -88,11 +86,21 @@ assignArgumentsPos dflags conv arg_ty reps = assignments ...@@ -88,11 +86,21 @@ assignArgumentsPos dflags conv arg_ty reps = assignments
gcp | isGcPtrType ty = VGcPtr gcp | isGcPtrType ty = VGcPtr
| otherwise = VNonGcPtr | 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) 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 off' = offset + size
word_size = wORD_SIZE dflags
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- Local information about the registers available -- Local information about the registers available
...@@ -158,3 +166,9 @@ globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++ ...@@ -158,3 +166,9 @@ globalArgRegs dflags = map ($ VGcPtr) (allVanillaRegs dflags) ++
allFloatRegs dflags ++ allFloatRegs dflags ++
allDoubleRegs dflags ++ allDoubleRegs dflags ++
allLongRegs dflags allLongRegs dflags
realArgRegs :: DynFlags -> [GlobalReg]
realArgRegs dflags = map ($VGcPtr) (realVanillaRegs dflags) ++
realFloatRegs dflags ++
realDoubleRegs dflags ++
realLongRegs dflags
...@@ -97,15 +97,17 @@ cmmCfgOptsProc _ top = top ...@@ -97,15 +97,17 @@ cmmCfgOptsProc _ top = top
blockConcat :: Bool -> CmmGraph -> (CmmGraph, BlockEnv BlockId) blockConcat :: Bool -> CmmGraph -> (CmmGraph, BlockEnv BlockId)
blockConcat splitting_procs g@CmmGraph { g_entry = entry_id } 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 where
-- we might be able to shortcut the entry BlockId itself -- we might be able to shortcut the entry BlockId itself.
new_entry -- 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 entry_blk <- mapLookup entry_id new_blocks
, Just dest <- canShortcut entry_blk , Just dest <- canShortcut entry_blk
= dest = (dest, mapInsert entry_id dest shortcut_map)
| otherwise | otherwise
= entry_id = (entry_id, shortcut_map)
blocks = postorderDfs g blocks = postorderDfs g
blockmap = foldr addBlock emptyBody blocks blockmap = foldr addBlock emptyBody blocks
......
...@@ -22,19 +22,23 @@ cmmOfZgraph tops = map mapTop tops ...@@ -22,19 +22,23 @@ cmmOfZgraph tops = map mapTop tops
where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g) where mapTop (CmmProc h l g) = CmmProc (info_tbls h) l (ofZgraph g)
mapTop (CmmData s ds) = CmmData s ds 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] get_hints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd) get_hints (PrimTarget op) = (res_hints ++ repeat NoHint,
arg_hints ++ repeat NoHint)
get_hints :: ForeignTarget -> ValueDirection -> [ForeignHint] where (res_hints, arg_hints) = callishMachOpHints op
get_hints (ForeignTarget _ (ForeignConvention _ hints _)) Arguments = hints get_hints (ForeignTarget _ (ForeignConvention _ arg_hints res_hints _))
get_hints (ForeignTarget _ (ForeignConvention _ _ hints)) Results = hints = (res_hints, arg_hints)
get_hints (PrimTarget _) _vd = repeat NoHint
cmm_target :: ForeignTarget -> Old.CmmCallTarget cmm_target :: ForeignTarget -> Old.CmmCallTarget
cmm_target (PrimTarget op) = Old.CmmPrim op Nothing 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 :: CmmGraph -> Old.ListGraph Old.CmmStmt
ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
...@@ -83,11 +87,14 @@ 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 CmmAssign l r -> Old.CmmAssign l r
CmmStore l r -> Old.CmmStore l r CmmStore l r -> Old.CmmStore l r
CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
CmmUnsafeForeignCall target ress args -> CmmUnsafeForeignCall target ress args ->
Old.CmmCall (cmm_target target) Old.CmmCall (cmm_target target)
(add_hints target Results ress) (add_hints ress res_hints)
(add_hints target Arguments args) (add_hints args arg_hints)
Old.CmmMayReturn (get_ret target)
where
(res_hints, arg_hints) = get_hints target
last :: CmmNode O C -> () -> [Old.CmmStmt] last :: CmmNode O C -> () -> [Old.CmmStmt]
last node _ = stmts last node _ = stmts
......
...@@ -155,7 +155,7 @@ type InfoTableContents = ( [CmmLit] -- The standard part ...@@ -155,7 +155,7 @@ type InfoTableContents = ( [CmmLit] -- The standard part
mkInfoTableContents :: DynFlags mkInfoTableContents :: DynFlags
-> CmmInfoTable -> CmmInfoTable
-> Maybe StgHalfWord -- Override default RTS type tag? -> Maybe Int -- Override default RTS type tag?
-> UniqSM ([RawCmmDecl], -- Auxiliary top decls -> UniqSM ([RawCmmDecl], -- Auxiliary top decls
InfoTableContents) -- Info tbl + extra bits InfoTableContents) -- Info tbl + extra bits
...@@ -178,22 +178,19 @@ mkInfoTableContents dflags ...@@ -178,22 +178,19 @@ mkInfoTableContents dflags
; let ; let
std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
rts_tag | Just tag <- mb_rts_tag = tag rts_tag | Just tag <- mb_rts_tag = tag
| null liveness_data = rET_SMALL dflags -- Fits in extra_bits | null liveness_data = rET_SMALL -- Fits in extra_bits
| otherwise = rET_BIG dflags -- Does not; extra_bits is | otherwise = rET_BIG -- Does not; extra_bits is
-- a label -- a label
; return (prof_data ++ liveness_data, (std_info, srt_label)) } ; return (prof_data ++ liveness_data, (std_info, srt_label)) }
| HeapRep _ ptrs nonptrs closure_type <- smrep | HeapRep _ ptrs nonptrs closure_type <- smrep
= do { let layout = packHalfWordsCLit = do { let layout = packIntsCLit dflags ptrs nonptrs
dflags
(toStgHalfWord dflags (toInteger ptrs))
(toStgHalfWord dflags (toInteger nonptrs))
; (prof_lits, prof_data) <- mkProfLits dflags prof ; (prof_lits, prof_data) <- mkProfLits dflags prof
; let (srt_label, srt_bitmap) = mkSRTLit dflags srt ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
; (mb_srt_field, mb_layout, extra_bits, ct_data) ; (mb_srt_field, mb_layout, extra_bits, ct_data)
<- mk_pieces closure_type srt_label <- mk_pieces closure_type srt_label
; let std_info = mkStdInfoTable dflags prof_lits ; 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_srt_field `orElse` srt_bitmap)
(mb_layout `orElse` layout) (mb_layout `orElse` layout)
; return (prof_data ++ ct_data, (std_info, extra_bits)) } ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
...@@ -205,24 +202,25 @@ mkInfoTableContents dflags ...@@ -205,24 +202,25 @@ mkInfoTableContents dflags
, [RawCmmDecl]) -- Auxiliary data decls , [RawCmmDecl]) -- Auxiliary data decls
mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor
= do { (descr_lit, decl) <- newStringLit con_descr = 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 mk_pieces Thunk srt_label
= return (Nothing, Nothing, srt_label, []) = return (Nothing, Nothing, srt_label, [])
mk_pieces (ThunkSelector offset) _no_srt 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 -- Layout known (one free var); we use the layout field for offset
mk_pieces (Fun arity (ArgSpec fun_type)) srt_label 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, []) } ; return (Nothing, Nothing, extra_bits, []) }
mk_pieces (Fun arity (ArgGen arg_bits)) srt_label mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
= do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
; let fun_type | null liveness_data = aRG_GEN dflags ; let fun_type | null liveness_data = aRG_GEN
| otherwise = aRG_GEN_BIG dflags | otherwise = aRG_GEN_BIG
extra_bits = [ packHalfWordsCLit dflags fun_type arity extra_bits = [ packIntsCLit dflags fun_type arity
, srt_lit, liveness_lit, slow_entry ] , srt_lit, liveness_lit, slow_entry ]
; return (Nothing, Nothing, extra_bits, liveness_data) } ; return (Nothing, Nothing, extra_bits, liveness_data) }
where where
...@@ -233,9 +231,14 @@ mkInfoTableContents dflags ...@@ -233,9 +231,14 @@ mkInfoTableContents dflags
mk_pieces BlackHole _ = panic "mk_pieces: BlackHole" mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"
mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier 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 mkSRTLit :: DynFlags
-> C_SRT -> C_SRT
-> ([CmmLit], -- srt_label, if any -> ([CmmLit], -- srt_label, if any
...@@ -314,7 +317,7 @@ mkLivenessBits dflags liveness ...@@ -314,7 +317,7 @@ mkLivenessBits dflags liveness
[mkRODataLits bitmap_lbl lits]) } [mkRODataLits bitmap_lbl lits]) }
| otherwise -- Fits in one word | otherwise -- Fits in one word
= return (mkWordCLit dflags bitmap_word, []) = return (mkStgWordCLit dflags bitmap_word, [])
where where
n_bits = length liveness n_bits = length liveness
...@@ -328,7 +331,8 @@ mkLivenessBits dflags liveness ...@@ -328,7 +331,8 @@ mkLivenessBits dflags liveness
bitmap_word = toStgWord dflags (fromIntegral n_bits) bitmap_word = toStgWord dflags (fromIntegral n_bits)
.|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags) .|. (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 -- The first word is the size. The structure must match
-- StgLargeBitmap in includes/rts/storage/InfoTable.h -- StgLargeBitmap in includes/rts/storage/InfoTable.h
...@@ -348,8 +352,8 @@ mkLivenessBits dflags liveness ...@@ -348,8 +352,8 @@ mkLivenessBits dflags liveness
mkStdInfoTable mkStdInfoTable
:: DynFlags :: DynFlags
-> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling)
-> StgHalfWord -- Closure RTS tag -> Int -- Closure RTS tag
-> StgHalfWord -- SRT length -> StgHalfWord -- SRT length
-> CmmLit -- layout field -> CmmLit -- layout field
-> [CmmLit] -> [CmmLit]
...@@ -365,7 +369,7 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit ...@@ -365,7 +369,7 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
| dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] | dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
| otherwise = [] | otherwise = []
type_lit = packHalfWordsCLit dflags cl_type srt_len type_lit = packHalfWordsCLit dflags (toStgHalfWord dflags (fromIntegral cl_type)) srt_len
------------------------------------------------------------------------- -------------------------------------------------------------------------
-- --
......
...@@ -933,7 +933,7 @@ lowerSafeForeignCall dflags block ...@@ -933,7 +933,7 @@ lowerSafeForeignCall dflags block
(ret_args, regs, copyout) = copyOutOflow dflags NativeReturn Jump (Young succ) (ret_args, regs, copyout) = copyOutOflow dflags NativeReturn Jump (Young succ)
(map (CmmReg . CmmLocal) res) (map (CmmReg . CmmLocal) res)
updfr (0, []) updfr []
-- NB. after resumeThread returns, the top-of-stack probably contains -- NB. after resumeThread returns, the top-of-stack probably contains
-- the stack frame for succ, but it might not: if the current thread -- the stack frame for succ, but it might not: if the current thread
...@@ -973,14 +973,14 @@ callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O ...@@ -973,14 +973,14 @@ callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
callSuspendThread dflags id intrbl = callSuspendThread dflags id intrbl =
CmmUnsafeForeignCall CmmUnsafeForeignCall
(ForeignTarget (foreignLbl (fsLit "suspendThread")) (ForeignTarget (foreignLbl (fsLit "suspendThread"))
(ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint])) (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
[id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)] [id] [CmmReg (CmmGlobal BaseReg), mkIntExpr dflags (fromEnum intrbl)]
callResumeThread :: LocalReg -> LocalReg -> CmmNode O O callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread new_base id = callResumeThread new_base id =
CmmUnsafeForeignCall CmmUnsafeForeignCall
(ForeignTarget (foreignLbl (fsLit "resumeThread")) (ForeignTarget (foreignLbl (fsLit "resumeThread"))
(ForeignConvention CCallConv [AddrHint] [AddrHint])) (ForeignConvention CCallConv [AddrHint] [AddrHint] CmmMayReturn))
[new_base] [CmmReg (CmmLocal id)] [new_base] [CmmReg (CmmLocal id)]
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
......
...@@ -23,9 +23,9 @@ module CmmLex ( ...@@ -23,9 +23,9 @@ module CmmLex (
CmmToken(..), cmmlex, CmmToken(..), cmmlex,
) where ) where
import OldCmm import CmmExpr
import Lexer
import Lexer
import SrcLoc import SrcLoc
import UniqFM import UniqFM
import StringBuffer import StringBuffer
...@@ -147,6 +147,7 @@ data CmmToken ...@@ -147,6 +147,7 @@ data CmmToken
| CmmT_align | CmmT_align
| CmmT_goto | CmmT_goto
| CmmT_if | CmmT_if
| CmmT_call
| CmmT_jump | CmmT_jump
| CmmT_foreign | CmmT_foreign
| CmmT_never | CmmT_never
...@@ -157,6 +158,7 @@ data CmmToken ...@@ -157,6 +158,7 @@ data CmmToken
| CmmT_switch | CmmT_switch
| CmmT_case | CmmT_case
| CmmT_default | CmmT_default
| CmmT_push
| CmmT_bits8 | CmmT_bits8
| CmmT_bits16 | CmmT_bits16
| CmmT_bits32 | CmmT_bits32
...@@ -224,8 +226,9 @@ reservedWordsFM = listToUFM $ ...@@ -224,8 +226,9 @@ reservedWordsFM = listToUFM $
( "align", CmmT_align ), ( "align", CmmT_align ),
( "goto", CmmT_goto ), ( "goto", CmmT_goto ),
( "if", CmmT_if ), ( "if", CmmT_if ),
( "jump", CmmT_jump ), ( "call", CmmT_call ),
( "foreign", CmmT_foreign ), ( "jump", CmmT_jump ),
( "foreign", CmmT_foreign ),
( "never", CmmT_never ), ( "never", CmmT_never ),
( "prim", CmmT_prim ), ( "prim", CmmT_prim ),
( "return", CmmT_return ), ( "return", CmmT_return ),
...@@ -233,8 +236,9 @@ reservedWordsFM = listToUFM $ ...@@ -233,8 +236,9 @@ reservedWordsFM = listToUFM $
( "import", CmmT_import ), ( "import", CmmT_import ),
( "switch", CmmT_switch ), ( "switch", CmmT_switch ),