summaryrefslogtreecommitdiff
path: root/compiler/cmm
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/cmm')
-rw-r--r--compiler/cmm/CLabel.hs15
-rw-r--r--compiler/cmm/Cmm.hs7
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs7
-rw-r--r--compiler/cmm/CmmCallConv.hs66
-rw-r--r--compiler/cmm/CmmContFlowOpt.hs12
-rw-r--r--compiler/cmm/CmmCvt.hs33
-rw-r--r--compiler/cmm/CmmInfo.hs46
-rw-r--r--compiler/cmm/CmmLayoutStack.hs6
-rw-r--r--compiler/cmm/CmmLex.x16
-rw-r--r--compiler/cmm/CmmMachOp.hs9
-rw-r--r--compiler/cmm/CmmNode.hs46
-rw-r--r--compiler/cmm/CmmOpt.hs21
-rw-r--r--compiler/cmm/CmmParse.y1279
-rw-r--r--compiler/cmm/CmmPipeline.hs13
-rw-r--r--compiler/cmm/CmmProcPoint.hs7
-rw-r--r--compiler/cmm/CmmSink.hs58
-rw-r--r--compiler/cmm/CmmType.hs18
-rw-r--r--compiler/cmm/CmmUtils.hs18
-rw-r--r--compiler/cmm/MkGraph.hs148
-rw-r--r--compiler/cmm/OldCmm.hs9
-rw-r--r--compiler/cmm/OldPprCmm.hs8
-rw-r--r--compiler/cmm/PprC.hs1
-rw-r--r--compiler/cmm/PprCmm.hs17
-rw-r--r--compiler/cmm/SMRep.lhs37
24 files changed, 1118 insertions, 779 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index a5d559e9ff..04312321cc 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -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
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 2dedee0d52..8409f0dbeb 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -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
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index ecaab57d76..304f4c2170 100644
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -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
diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs
index 235fe7f911..180b2d7eab 100644
--- a/compiler/cmm/CmmCallConv.hs
+++ b/compiler/cmm/CmmCallConv.hs
@@ -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
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
index aa2925fe53..4028efddf6 100644
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -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
diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs
index cd838821b3..017d120d84 100644
--- a/compiler/cmm/CmmCvt.hs
+++ b/compiler/cmm/CmmCvt.hs
@@ -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
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 6aa4d6cbfa..dec6b5d09d 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -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
-------------------------------------------------------------------------
--
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/cmm/CmmLayoutStack.hs
index 6f75f5451c..5c4045778a 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/cmm/CmmLayoutStack.hs
@@ -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)]
-- -----------------------------------------------------------------------------
diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x
index ddd681d25e..718eb27c82 100644
--- a/compiler/cmm/CmmLex.x
+++ b/compiler/cmm/CmmLex.x
@@ -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 ),
diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs
index 520c7e7a7d..c00cdb5b5a 100644
--- a/compiler/cmm/CmmMachOp.hs
+++ b/compiler/cmm/CmmMachOp.hs
@@ -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
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index ae7ac091de..b7bb270bd6 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -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
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index 32afa1d078..843626303a 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -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
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 8c3559b774..22e28a8a9d 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -1,14 +1,160 @@
-----------------------------------------------------------------------------
--
--- (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
@@ -21,30 +167,32 @@
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
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 5fca9e7164..4f5d3b926c 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -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 ------------
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs
index 471faf8b0c..19f0155908 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/cmm/CmmProcPoint.hs
@@ -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
diff --git a/compiler/cmm/CmmSink.hs b/compiler/cmm/CmmSink.hs
index 2ff9b98d2a..6dccdabe89 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/cmm/CmmSink.hs
@@ -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
diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs
index d6da5a4022..9a443c1ae2 100644
--- a/compiler/cmm/CmmType.hs
+++ b/compiler/cmm/CmmType.hs
@@ -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.
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index bf93a2f6ff..f420e7d94e 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -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
diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs
index 4ba82cd8f8..1e2ddfadd1 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/cmm/MkGraph.hs
@@ -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]
diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs
index 05aa5fb811..3d0599b7ea 100644
--- a/compiler/cmm/OldCmm.hs
+++ b/compiler/cmm/OldCmm.hs
@@ -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
diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs
index a3857d4e47..dcde86e37c 100644
--- a/compiler/cmm/OldPprCmm.hs
+++ b/compiler/cmm/OldPprCmm.hs
@@ -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 ->
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 1a3eb0d716..a2427df868 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -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
-- ---------------------------------------------------------------------
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 423bcd5504..f3e2a02737 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -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')
diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs
index d9644488fc..ac021df761 100644
--- a/compiler/cmm/SMRep.lhs
+++ b/compiler/cmm/SMRep.lhs
@@ -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]