Implement unboxed sum primitive type
[ghc.git] / compiler / cmm / MkGraph.hs
index 657585e..b1bd48a 100644 (file)
@@ -7,7 +7,8 @@ module MkGraph
   , lgraphOfAGraph, labelAGraph
 
   , stackStubExpr
-  , mkNop, mkAssign, mkStore, mkUnsafeCall, mkFinalCall, mkCallReturnsTo
+  , mkNop, mkAssign, mkAssign', mkStore, mkStore'
+  , mkUnsafeCall, mkFinalCall, mkCallReturnsTo
   , mkJumpReturnsTo
   , mkJump, mkJumpExtra
   , mkRawJump
@@ -16,26 +17,31 @@ module MkGraph
   , copyInOflow, copyOutOflow
   , noExtraStack
   , toCall, Transfer(..)
+  , rubbishExpr
   )
 where
 
 import BlockId
+import CLabel (mkRUBBISH_ENTRY_infoLabel)
 import Cmm
 import CmmCallConv
 import CmmSwitch (SwitchTargets)
+import CmmUtils (cmmArgType)
+import TyCon (isGcPtrRep)
+import RepType (typePrimRep)
 
 import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
 import DynFlags
 import FastString
 import ForeignCall
+import OrdList
 import SMRep (ByteOff)
 import UniqSupply
-import OrdList
 
 import Control.Monad
 import Data.List
 import Data.Maybe
-import Prelude (($),Int,Bool,Eq(..)) -- avoid importing (<*>)
+import Prelude (($),Int,Bool,Eq(..),otherwise) -- avoid importing (<*>)
 
 #include "HsVersions.h"
 
@@ -193,12 +199,30 @@ mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
 mkAssign l (CmmReg r) | l == r  = mkNop
 mkAssign l r  = mkMiddle $ CmmAssign l r
 
+mkAssign' :: CmmReg -> CmmArg -> CmmAGraph
+mkAssign' l (CmmRubbishArg ty)
+  | isGcPtrRep (typePrimRep ty)
+  = mkAssign l rubbishExpr
+  | otherwise
+  = mkNop
+mkAssign' l (CmmExprArg r)
+  = mkAssign l r
+
 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph
 mkStore  l r  = mkMiddle $ CmmStore  l r
 
+mkStore' :: CmmExpr -> CmmArg -> CmmAGraph
+mkStore' l (CmmRubbishArg ty)
+  | isGcPtrRep (typePrimRep ty)
+  = mkStore l rubbishExpr
+  | otherwise
+  = mkNop
+mkStore' l (CmmExprArg r)
+  = mkStore l r
+
 ---------- Control transfer
 mkJump          :: DynFlags -> Convention -> CmmExpr
-                -> [CmmActual]
+                -> [CmmArg]
                 -> UpdFrameOffset
                 -> CmmAGraph
 mkJump dflags conv e actuals updfr_off =
@@ -214,8 +238,8 @@ mkRawJump dflags e updfr_off vols =
     \arg_space _  -> toCall e Nothing updfr_off 0 arg_space vols
 
 
-mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmActual]
-                -> UpdFrameOffset -> [CmmActual]
+mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmArg]
+                -> UpdFrameOffset -> [CmmArg]
                 -> CmmAGraph
 mkJumpExtra dflags conv e actuals updfr_off extra_stack =
   lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
@@ -228,7 +252,7 @@ mkCbranch pred ifso ifnot likely =
 mkSwitch        :: CmmExpr -> SwitchTargets -> CmmAGraph
 mkSwitch e tbl   = mkLast $ CmmSwitch e tbl
 
-mkReturn        :: DynFlags -> CmmExpr -> [CmmActual] -> UpdFrameOffset
+mkReturn        :: DynFlags -> CmmExpr -> [CmmArg] -> UpdFrameOffset
                 -> CmmAGraph
 mkReturn dflags e actuals updfr_off =
   lastWithArgs dflags Ret  Old NativeReturn actuals updfr_off $
@@ -238,17 +262,17 @@ mkBranch        :: BlockId -> CmmAGraph
 mkBranch bid     = mkLast (CmmBranch bid)
 
 mkFinalCall   :: DynFlags
-              -> CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset
+              -> CmmExpr -> CCallConv -> [CmmArg] -> UpdFrameOffset
               -> CmmAGraph
 mkFinalCall dflags f _ actuals updfr_off =
   lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
     toCall f Nothing updfr_off 0
 
-mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
+mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmArg]
                 -> BlockId
                 -> ByteOff
                 -> UpdFrameOffset
-                -> [CmmActual]
+                -> [CmmArg]
                 -> CmmAGraph
 mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
   lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
@@ -257,7 +281,7 @@ mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack
 
 -- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
 -- already on the stack).
-mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmActual]
+mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmArg]
                 -> BlockId
                 -> ByteOff
                 -> UpdFrameOffset
@@ -325,9 +349,9 @@ copyIn dflags conv area formals extra_stk
 
 data Transfer = Call | JumpRet | Jump | Ret deriving Eq
 
-copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmActual]
+copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmArg]
              -> UpdFrameOffset
-             -> [CmmActual] -- extra stack args
+             -> [CmmArg] -- extra stack args
              -> (Int, [GlobalReg], CmmAGraph)
 
 -- Generate code to move the actual parameters into the locations
@@ -345,9 +369,9 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
     (regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
 
     co (v, RegisterParam r) (rs, ms)
-       = (r:rs, mkAssign (CmmGlobal r) v <*> ms)
+       = (r:rs, mkAssign' (CmmGlobal r) v <*> ms)
     co (v, StackParam off)  (rs, ms)
-       = (rs, mkStore (CmmStackSlot area off) v <*> ms)
+       = (rs, mkStore' (CmmStackSlot area off) v <*> ms)
 
     (setRA, init_offset) =
       case area of
@@ -355,7 +379,7 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
                          -- the return address if making a call
                   case transfer of
                      Call ->
-                       ([(CmmLit (CmmBlock id), StackParam init_offset)],
+                       ([(CmmExprArg (CmmLit (CmmBlock id)), StackParam init_offset)],
                        widthInBytes (wordWidth dflags))
                      JumpRet ->
                        ([],
@@ -365,11 +389,11 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
             Old -> ([], updfr_off)
 
     (extra_stack_off, stack_params) =
-       assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff
+       assignStack dflags init_offset (cmmArgType dflags) extra_stack_stuff
 
-    args :: [(CmmExpr, ParamLocation)]   -- The argument and where to put it
+    args :: [(CmmArg, ParamLocation)]   -- The argument and where to put it
     (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
-                                          (cmmExprType dflags) actuals
+                                          (cmmArgType dflags) actuals
 
 
 
@@ -378,7 +402,7 @@ mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
 mkCallEntry dflags conv formals extra_stk
   = copyInOflow dflags conv Old formals extra_stk
 
-lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmActual]
+lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmArg]
              -> UpdFrameOffset
              -> (ByteOff -> [GlobalReg] -> CmmAGraph)
              -> CmmAGraph
@@ -387,8 +411,8 @@ lastWithArgs dflags transfer area conv actuals updfr_off last =
                             updfr_off noExtraStack last
 
 lastWithArgsAndExtraStack :: DynFlags
-             -> Transfer -> Area -> Convention -> [CmmActual]
-             -> UpdFrameOffset -> [CmmActual]
+             -> Transfer -> Area -> Convention -> [CmmArg]
+             -> UpdFrameOffset -> [CmmArg]
              -> (ByteOff -> [GlobalReg] -> CmmAGraph)
              -> CmmAGraph
 lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
@@ -399,7 +423,7 @@ lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
                                updfr_off extra_stack
 
 
-noExtraStack :: [CmmActual]
+noExtraStack :: [CmmArg]
 noExtraStack = []
 
 toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
@@ -407,3 +431,7 @@ toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff
        -> CmmAGraph
 toCall e cont updfr_off res_space arg_space regs =
   mkLast $ CmmCall e cont regs arg_space res_space updfr_off
+
+--------------
+rubbishExpr :: CmmExpr
+rubbishExpr = CmmLit (CmmLabel mkRUBBISH_ENTRY_infoLabel)