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 (
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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......@@ -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
......
......@@ -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
......
......@@ -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
-------------------------------------------------------------------------
--
......
......@@ -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)]
-- -----------------------------------------------------------------------------
......
......@@ -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 ),
......
......@@ -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
......@@ -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
......
......@@ -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
......
This diff is collapsed.
......@@ -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 ------------
......
......@@ -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
......
......@@ -6,6 +6,7 @@ module CmmSink (