Added pointerhood to LocalReg

This version should compile but is still incomplete as it introduces
potential bugs at the places marked 'TODO FIXME NOW'.
It is being recorded to help keep track of changes.

compiler/cmm/Cmm.hs

@@ -10,13 +10,13 @@ module Cmm (
 	GenCmm(..), Cmm,
 	GenCmmTop(..), CmmTop,
 	GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts,
-	CmmStmt(..), CmmActuals, CmmFormals,
+	CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
 	CmmCallTarget(..),
 	CmmStatic(..), Section(..),
 	CmmExpr(..), cmmExprRep, 
 	CmmReg(..), cmmRegRep,
 	CmmLit(..), cmmLitRep,
-	LocalReg(..), localRegRep,
+	LocalReg(..), localRegRep, Kind(..),
 	BlockId(..), BlockEnv,
 	GlobalReg(..), globalRegRep,
 
@@ -114,7 +114,7 @@ data CmmStmt
 
   | CmmCall	 		 -- A foreign call, with 
      CmmCallTarget
-     CmmFormals			 -- zero or more results
+     CmmHintFormals		 -- zero or more results
      CmmActuals			 -- zero or more arguments
 
   | CmmBranch BlockId             -- branch to another BB in this fn
@@ -133,8 +133,11 @@ data CmmStmt
   | CmmReturn                     -- Return from a function,
       CmmActuals                  -- with these return values.
 
-type CmmActuals = [(CmmExpr,MachHint)]
-type CmmFormals = [(CmmReg,MachHint)]
+type CmmActual = CmmExpr
+type CmmActuals = [(CmmActual,MachHint)]
+type CmmFormal = LocalReg
+type CmmHintFormals = [(CmmFormal,MachHint)]
+type CmmFormals = [CmmFormal]
 
 {-
 Discussion
@@ -221,17 +224,25 @@ cmmRegRep :: CmmReg -> MachRep
 cmmRegRep (CmmLocal  reg) 	= localRegRep reg
 cmmRegRep (CmmGlobal reg)	= globalRegRep reg
 
+-- | Whether a 'LocalReg' is a GC followable pointer
+data Kind = KindPtr | KindNonPtr deriving (Eq)
+
 data LocalReg
-  = LocalReg !Unique MachRep
+  = LocalReg
+      !Unique   -- ^ Identifier
+      MachRep   -- ^ Type
+      Kind      -- ^ Should the GC follow as a pointer
 
 instance Eq LocalReg where
-  (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
+  (LocalReg u1 _ _) == (LocalReg u2 _ _) = u1 == u2
 
 instance Uniquable LocalReg where
-  getUnique (LocalReg uniq _) = uniq
+  getUnique (LocalReg uniq _ _) = uniq
 
 localRegRep :: LocalReg -> MachRep
-localRegRep (LocalReg _ rep) = rep
+localRegRep (LocalReg _ rep _) = rep
+
+localRegGCFollow (LocalReg _ _ p) = p
 
 data CmmLit
   = CmmInt Integer  MachRep

compiler/cmm/CmmBrokenBlock.hs

@@ -78,7 +78,7 @@ data FinalStmt
       BlockId                   -- ^ Target of the 'CmmGoto'
                                 -- (must be a 'ContinuationEntry')
       CmmCallTarget             -- ^ The function to call
-      CmmFormals                -- ^ Results from call
+      CmmHintFormals                -- ^ Results from call
                                 -- (redundant with ContinuationEntry)
       CmmActuals                -- ^ Arguments to call
 
@@ -142,7 +142,7 @@ breakBlock uniques (BasicBlock ident stmts) entry =
                 block = do_call current_id entry accum_stmts exits next_id
                                 target results arguments
                 rest = breakBlock' (tail uniques) next_id
-                                   (ContinuationEntry results) [] [] stmts
+                                   (ContinuationEntry (map fst results)) [] [] stmts
             (s:stmts) ->
                 breakBlock' uniques current_id entry
                             (cond_branch_target s++exits)

compiler/cmm/CmmCPS.hs

@@ -157,7 +157,7 @@ data StackFormat
     = StackFormat {
          stack_label :: Maybe CLabel,	-- The label occupying the top slot
          stack_frame_size :: WordOff,	-- Total frame size in words (not including arguments)
-         stack_live :: [(CmmReg, WordOff)]	-- local reg offsets from stack top
+         stack_live :: [(LocalReg, WordOff)]	-- local reg offsets from stack top
                        -- TODO: see if the above can be LocalReg
       }
 
@@ -230,11 +230,11 @@ selectStackFormat live continuations =
       live_to_format label formals live =
           foldl extend_format
                     (StackFormat (Just label) retAddrSizeW [])
-                    (uniqSetToList (live `minusUniqSet` mkUniqSet (cmmFormalsToLiveLocals formals)))
+                    (uniqSetToList (live `minusUniqSet` mkUniqSet formals))
 
       extend_format :: StackFormat -> LocalReg -> StackFormat
       extend_format (StackFormat label size offsets) reg =
-          StackFormat label (slot_size reg + size) ((CmmLocal reg, size) : offsets)
+          StackFormat label (slot_size reg + size) ((reg, size) : offsets)
 
       slot_size :: LocalReg -> Int
       slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
@@ -315,7 +315,7 @@ pack_continuation (StackFormat curr_id curr_frame_size _)
   = store_live_values ++ set_stack_header where
     -- TODO: only save variables when actually needed (may be handled by latter pass)
     store_live_values =
-        [stack_put spRel (CmmReg reg) offset
+        [stack_put spRel (CmmReg (CmmLocal reg)) offset
          | (reg, offset) <- cont_offsets]
     set_stack_header =
         if not needs_header
@@ -342,11 +342,11 @@ function_entry formals (StackFormat _ _ curr_offsets)
          | (reg, offset) <- curr_offsets]
     load_args =
         [stack_get 0 reg offset
-         | ((reg, _), StackParam offset) <- argument_formats] ++
+         | (reg, StackParam offset) <- argument_formats] ++
         [global_get reg global
-         | ((reg, _), RegisterParam global) <- argument_formats]
+         | (reg, RegisterParam global) <- argument_formats]
 
-    argument_formats = assignArguments (cmmRegRep . fst) formals
+    argument_formats = assignArguments (localRegRep) formals
 
 -----------------------------------------------------------------------------
 -- Section: Stack and argument register puts and gets
@@ -366,13 +366,13 @@ stack_put spRel expr offset =
 --------------------------------
 -- |Construct a 
 stack_get :: WordOff
-          -> CmmReg
+          -> LocalReg
           -> WordOff
           -> CmmStmt
 stack_get spRel reg offset =
-    CmmAssign reg (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) (cmmRegRep reg))
+    CmmAssign (CmmLocal reg) (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) (localRegRep reg))
 global_put :: CmmExpr -> GlobalReg -> CmmStmt
 global_put expr global = CmmAssign (CmmGlobal global) expr
-global_get :: CmmReg -> GlobalReg -> CmmStmt
-global_get reg global = CmmAssign reg (CmmReg (CmmGlobal global))
+global_get :: LocalReg -> GlobalReg -> CmmStmt
+global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))
 

compiler/cmm/CmmLive.hs

@@ -2,7 +2,7 @@ module CmmLive (
         CmmLive,
         BlockEntryLiveness,
         cmmLiveness,
-        cmmFormalsToLiveLocals,
+        cmmHintFormalsToLiveLocals,
   ) where
 
 #include "HsVersions.h"
@@ -156,10 +156,8 @@ addKilled new_killed live = live `minusUniqSet` new_killed
 --------------------------------
 -- Liveness of a CmmStmt
 --------------------------------
-cmmFormalsToLiveLocals :: CmmFormals -> [LocalReg]
-cmmFormalsToLiveLocals [] = []
-cmmFormalsToLiveLocals ((CmmGlobal _,_):args) = cmmFormalsToLiveLocals args
-cmmFormalsToLiveLocals ((CmmLocal r,_):args) = r:cmmFormalsToLiveLocals args
+cmmHintFormalsToLiveLocals :: CmmHintFormals -> [LocalReg]
+cmmHintFormalsToLiveLocals formals = map fst formals
 
 cmmStmtLive :: BlockEntryLiveness -> CmmStmt -> CmmLivenessTransformer
 cmmStmtLive _ (CmmNop) = id
@@ -175,7 +173,7 @@ cmmStmtLive _ (CmmStore expr1 expr2) =
 cmmStmtLive _ (CmmCall target results arguments) =
     target_liveness .
     foldr ((.) . cmmExprLive) id (map fst arguments) .
-    addKilled (mkUniqSet $ cmmFormalsToLiveLocals results) where
+    addKilled (mkUniqSet $ cmmHintFormalsToLiveLocals results) where
         target_liveness =
             case target of
               (CmmForeignCall target _) -> cmmExprLive target

compiler/cmm/CmmOpt.hs

@@ -93,7 +93,7 @@ cmmMiniInline blocks = map do_inline blocks
 
 cmmMiniInlineStmts :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
 cmmMiniInlineStmts uses [] = []
-cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts)
+cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _ _)) expr) : stmts)
   | Just 1 <- lookupUFM uses u,
     Just stmts' <- lookForInline u expr stmts
   = 
@@ -109,7 +109,7 @@ cmmMiniInlineStmts uses (stmt:stmts)
 -- Try to inline a temporary assignment.  We can skip over assignments to
 -- other tempoararies, because we know that expressions aren't side-effecting
 -- and temporaries are single-assignment.
-lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _)) rhs) : rest)
+lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _ _)) rhs) : rest)
   | u /= u' 
   = case lookupUFM (getExprUses rhs) u of
 	Just 1 -> Just (inlineStmt u expr stmt : rest)
@@ -150,8 +150,8 @@ getStmtUses (CmmJump e _) = getExprUses e
 getStmtUses _ = emptyUFM
 
 getExprUses :: CmmExpr -> UniqFM Int
-getExprUses (CmmReg (CmmLocal (LocalReg u _))) = unitUFM u 1
-getExprUses (CmmRegOff (CmmLocal (LocalReg u _)) _) = unitUFM u 1
+getExprUses (CmmReg (CmmLocal (LocalReg u _ _))) = unitUFM u 1
+getExprUses (CmmRegOff (CmmLocal (LocalReg u _ _)) _) = unitUFM u 1
 getExprUses (CmmLoad e _) = getExprUses e
 getExprUses (CmmMachOp _ es) = getExprsUses es
 getExprUses _other = emptyUFM
@@ -172,10 +172,10 @@ inlineStmt u a (CmmJump e d) = CmmJump (inlineExpr u a e) d
 inlineStmt u a other_stmt = other_stmt
 
 inlineExpr :: Unique -> CmmExpr -> CmmExpr -> CmmExpr
-inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _)))
+inlineExpr u a e@(CmmReg (CmmLocal (LocalReg u' _ _)))
   | u == u' = a
   | otherwise = e
-inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep)) off)
+inlineExpr u a e@(CmmRegOff (CmmLocal (LocalReg u' rep _)) off)
   | u == u' = CmmMachOp (MO_Add rep) [a, CmmLit (CmmInt (fromIntegral off) rep)]
   | otherwise = e
 inlineExpr u a (CmmLoad e rep) = CmmLoad (inlineExpr u a e) rep

compiler/cmm/CmmParse.y

@@ -244,7 +244,10 @@ body	:: { ExtCode }
 	| stmt body			{ do $1; $2 }
 
 decl	:: { ExtCode }
-	: type names ';'		{ mapM_ (newLocal $1) $2 }
+	: type names ';'		{ mapM_ (newLocal defaultKind $1) $2 }
+	| STRING type names ';'		{% do k <- parseKind $1;
+					      return $ mapM_ (newLocal k $2) $3 }
+
 	| 'import' names ';'		{ return () }  -- ignore imports
 	| 'export' names ';'		{ return () }  -- ignore exports
 
@@ -401,21 +404,32 @@ reg	:: { ExtFCode CmmExpr }
 	: NAME			{ lookupName $1 }
 	| GLOBALREG		{ return (CmmReg (CmmGlobal $1)) }
 
-maybe_results :: { [ExtFCode (CmmReg, MachHint)] }
+maybe_results :: { [ExtFCode (CmmFormal, MachHint)] }
 	: {- empty -}		{ [] }
 	| hint_lregs '='	{ $1 }
 
-hint_lregs :: { [ExtFCode (CmmReg, MachHint)] }
+hint_lregs0 :: { [ExtFCode (CmmFormal, MachHint)] }
+	: {- empty -}		{ [] }
+	| hint_lregs		{ $1 }
+
+hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] }
 	: hint_lreg ','			{ [$1] }
 	| hint_lreg			{ [$1] }
 	| hint_lreg ',' hint_lregs	{ $1 : $3 }
 
-hint_lreg :: { ExtFCode (CmmReg, MachHint) }
-	: lreg				{ do e <- $1; return (e, inferHint (CmmReg e)) }
-	| STRING lreg			{% do h <- parseHint $1;
+hint_lreg :: { ExtFCode (CmmFormal, MachHint) }
+	: local_lreg			{ do e <- $1; return (e, inferHint (CmmReg (CmmLocal e))) }
+	| STRING local_lreg		{% do h <- parseHint $1;
 					      return $ do
 						e <- $2; return (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 $
@@ -580,6 +594,13 @@ parseHint "signed" = return SignedHint
 parseHint "float"  = return FloatHint
 parseHint str      = fail ("unrecognised hint: " ++ str)
 
+parseKind :: String -> P Kind
+parseKind "ptr"    = return KindPtr
+parseKind str      = fail ("unrecognized kin: " ++ str)
+
+defaultKind :: Kind
+defaultKind = KindNonPtr
+
 -- labels are always pointers, so we might as well infer the hint
 inferHint :: CmmExpr -> MachHint
 inferHint (CmmLit (CmmLabel _)) = PtrHint
@@ -694,10 +715,12 @@ addVarDecl var expr = EC $ \e s -> return ((var, Var expr):s, ())
 addLabel :: FastString -> BlockId -> ExtCode
 addLabel name block_id = EC $ \e s -> return ((name, Label block_id):s, ())
 
-newLocal :: MachRep -> FastString -> ExtCode
-newLocal ty name  = do
+newLocal :: Kind -> MachRep -> FastString -> ExtFCode LocalReg
+newLocal kind ty name = do
    u <- code newUnique
-   addVarDecl name (CmmReg (CmmLocal (LocalReg u ty)))
+   let reg = LocalReg u ty kind
+   addVarDecl name (CmmReg (CmmLocal reg))
+   return reg
 
 newLabel :: FastString -> ExtFCode BlockId
 newLabel name = do
@@ -792,7 +815,7 @@ staticClosure cl_label info payload
 
 foreignCall
 	:: String
-	-> [ExtFCode (CmmReg,MachHint)]
+	-> [ExtFCode (CmmFormal,MachHint)]
 	-> ExtFCode CmmExpr
 	-> [ExtFCode (CmmExpr,MachHint)]
 	-> Maybe [GlobalReg] -> P ExtCode
@@ -809,7 +832,7 @@ foreignCall conv_string results_code expr_code args_code vols
                  (CmmForeignCall expr convention) args vols) where
 
 primCall
-	:: [ExtFCode (CmmReg,MachHint)]
+	:: [ExtFCode (CmmFormal,MachHint)]
 	-> FastString
 	-> [ExtFCode (CmmExpr,MachHint)]
 	-> Maybe [GlobalReg] -> P ExtCode

compiler/cmm/PprC.hs

@@ -206,7 +206,7 @@ pprStmt stmt = case stmt of
 	where
     	ppr_fn = case fn of
 		   CmmLit (CmmLabel lbl) -> pprCLabel lbl
-		   _other -> parens (cCast (pprCFunType cconv results args) fn)
+		   _ -> parens (cCast (pprCFunType cconv results args) fn)
 			-- for a dynamic call, cast the expression to
 			-- a function of the right type (we hope).
 
@@ -229,7 +229,7 @@ pprStmt stmt = case stmt of
     CmmJump lbl _params      -> mkJMP_(pprExpr lbl) <> semi
     CmmSwitch arg ids        -> pprSwitch arg ids
 
-pprCFunType :: CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)] -> SDoc
+pprCFunType :: CCallConv -> CmmHintFormals -> CmmActuals -> SDoc
 pprCFunType cconv ress args
   = hcat [
 	res_type ress,
@@ -238,7 +238,7 @@ pprCFunType cconv ress args
    ]
   where
 	res_type [] = ptext SLIT("void")
-	res_type [(one,hint)] = machRepHintCType (cmmRegRep one) hint
+	res_type [(one,hint)] = machRepHintCType (localRegRep one) hint
 
 	arg_type (expr,hint) = machRepHintCType (cmmExprRep expr) hint
 
@@ -713,12 +713,12 @@ pprGlobalReg gr = case gr of
     GCFun          -> ptext SLIT("stg_gc_fun")
 
 pprLocalReg :: LocalReg -> SDoc
-pprLocalReg (LocalReg uniq _rep) = char '_' <> ppr uniq
+pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq
 
 -- -----------------------------------------------------------------------------
 -- Foreign Calls
 
-pprCall :: SDoc -> CCallConv -> [(CmmReg,MachHint)] -> [(CmmExpr,MachHint)]
+pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals
 	-> SDoc
 
 pprCall ppr_fn cconv results args
@@ -741,17 +741,9 @@ pprCall ppr_fn cconv results args
     ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
   where 
      ppr_assign []           rhs = rhs
-     ppr_assign [(reg@(CmmGlobal BaseReg), hint)] rhs
-	 | Just ty <- strangeRegType reg
-	 = ptext SLIT("ASSIGN_BaseReg") <> parens (parens ty <> rhs)
-	 -- BaseReg is special, sometimes it isn't an lvalue and we
-	 -- can't assign to it.
      ppr_assign [(one,hint)] rhs
-	 | Just ty <- strangeRegType one
-	 = pprReg one <> ptext SLIT(" = ") <> parens ty <> rhs
-	 | otherwise
-	 = pprReg one <> ptext SLIT(" = ")
-		 <> pprUnHint hint (cmmRegRep one) <> rhs
+	 = pprLocalReg one <> ptext SLIT(" = ")
+		 <> pprUnHint hint (localRegRep one) <> rhs
      ppr_assign _other _rhs = panic "pprCall: multiple results"
 
      pprArg (expr, PtrHint)
@@ -792,7 +784,7 @@ pprDataExterns statics
   where (_, lbls) = runTE (mapM_ te_Static statics)
 
 pprTempDecl :: LocalReg -> SDoc
-pprTempDecl l@(LocalReg _uniq rep)
+pprTempDecl l@(LocalReg _ rep _)
   = hcat [ machRepCType rep, space, pprLocalReg l, semi ]
 
 pprExternDecl :: Bool -> CLabel -> SDoc
@@ -847,7 +839,7 @@ te_Lit _ = return ()
 te_Stmt :: CmmStmt -> TE ()
 te_Stmt (CmmAssign r e)		= te_Reg r >> te_Expr e
 te_Stmt (CmmStore l r)		= te_Expr l >> te_Expr r
-te_Stmt (CmmCall _ rs es)	= mapM_ (te_Reg.fst) rs >>
+te_Stmt (CmmCall _ rs es)	= mapM_ (te_temp.fst) rs >>
 				  mapM_ (te_Expr.fst) es
 te_Stmt (CmmCondBranch e _)	= te_Expr e
 te_Stmt (CmmSwitch e _)		= te_Expr e

compiler/cmm/PprCmm.hs

@@ -425,10 +425,14 @@ pprReg r
 -- We only print the type of the local reg if it isn't wordRep
 --
 pprLocalReg :: LocalReg -> SDoc
-pprLocalReg (LocalReg uniq rep) 
-    = hcat [ char '_', ppr uniq, 
-            (if rep == wordRep 
-                then empty else dcolon <> ppr rep) ]
+pprLocalReg (LocalReg uniq rep follow) 
+    = hcat [ char '_', ppr uniq, ty ] where
+  ty = if rep == wordRep && follow == KindNonPtr
+                then empty
+                else dcolon <> ptr <> ppr rep
+  ptr = if follow == KindNonPtr
+                then empty
+                else doubleQuotes (text "ptr")
 
 -- needs to be kept in syn with Cmm.hs.GlobalReg
 --

compiler/codeGen/CgBindery.lhs

@@ -22,7 +22,7 @@ module CgBindery (
 
 	bindArgsToStack,  rebindToStack,
 	bindNewToNode, bindNewToReg, bindArgsToRegs,
-	bindNewToTemp, 
+	bindNewToTemp,
 	getArgAmode, getArgAmodes, 
 	getCgIdInfo, 
 	getCAddrModeIfVolatile, getVolatileRegs,
@@ -391,13 +391,16 @@ bindNewToNode id offset lf_info
 -- Create a new temporary whose unique is that in the id,
 -- bind the id to it, and return the addressing mode for the
 -- temporary.
-bindNewToTemp :: Id -> FCode CmmReg
+bindNewToTemp :: Id -> FCode LocalReg
 bindNewToTemp id
-  = do	addBindC id (regIdInfo id temp_reg lf_info)
+  = do	addBindC id (regIdInfo id (CmmLocal temp_reg) lf_info)
 	return temp_reg
   where
     uniq     = getUnique id
-    temp_reg = CmmLocal (LocalReg uniq (argMachRep (idCgRep id)))
+    temp_reg = LocalReg uniq (argMachRep (idCgRep id)) kind
+    kind     = if isFollowableArg (idCgRep id)
+               then KindPtr
+               else KindNonPtr
     lf_info  = mkLFArgument id	-- Always used of things we
 				-- know nothing about
 

compiler/codeGen/CgCase.lhs

@@ -108,8 +108,8 @@ cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt
        alt_type@(PrimAlt tycon) alts
   = do	{ tmp_reg <- bindNewToTemp bndr
 	; cm_lit <- cgLit lit
-	; stmtC (CmmAssign tmp_reg (CmmLit cm_lit))
-	; cgPrimAlts NoGC alt_type tmp_reg alts }
+	; stmtC (CmmAssign (CmmLocal tmp_reg) (CmmLit cm_lit))
+	; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }
 \end{code}
 
 Special case #2: scrutinising a primitive-typed variable.	No
@@ -129,8 +129,8 @@ cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
 	  v_info <- getCgIdInfo v
 	; amode <- idInfoToAmode v_info
 	; tmp_reg <- bindNewToTemp bndr
-	; stmtC (CmmAssign tmp_reg amode)
-	; cgPrimAlts NoGC alt_type tmp_reg alts }
+	; stmtC (CmmAssign (CmmLocal tmp_reg) amode)
+	; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }
 \end{code}
 
 Special case #3: inline PrimOps and foreign calls.
@@ -285,7 +285,7 @@ cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts
   = do	{ 	-- PRIMITIVE ALTS, with non-void result
 	  tmp_reg <- bindNewToTemp bndr
 	; cgPrimOp [tmp_reg] primop args live_in_alts
-	; cgPrimAlts NoGC (PrimAlt tycon) tmp_reg alts }
+	; cgPrimAlts NoGC (PrimAlt tycon) (CmmLocal tmp_reg) alts }
 
 cgInlinePrimOp primop args bndr (UbxTupAlt tycon) live_in_alts alts
   = ASSERT( isSingleton alts )
@@ -315,7 +315,9 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
 	; this_pkg <- getThisPackage
 	; whenC (not (isDeadBinder bndr))
 		(do { tmp_reg <- bindNewToTemp bndr
-		    ; stmtC (CmmAssign tmp_reg (tagToClosure this_pkg tycon tag_amode)) })
+		    ; stmtC (CmmAssign
+                             (CmmLocal tmp_reg)
+                             (tagToClosure this_pkg tycon tag_amode)) })
 
 		-- Compile the alts
 	; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
@@ -332,9 +334,9 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
          (_,e) <- getArgAmode arg
 	 return e
     do_enum_primop primop
-      = do tmp <- newTemp wordRep
+      = do tmp <- newNonPtrTemp wordRep
 	   cgPrimOp [tmp] primop args live_in_alts
-    	   returnFC (CmmReg tmp)
+    	   returnFC (CmmReg (CmmLocal tmp))
 
 cgInlinePrimOp primop arg_amodes bndr PolyAlt live_in_alts alts
   = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr)

compiler/codeGen/CgExpr.lhs

@@ -117,17 +117,21 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
     reps_n_amodes <- getArgAmodes stg_args
     let 
 	-- Get the *non-void* args, and jiggle them with shimForeignCall
-	arg_exprs = [ shimForeignCallArg stg_arg expr 
+	arg_exprs = [ (shimForeignCallArg stg_arg expr, stg_arg)
 		    | (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes, 
 		      nonVoidArg rep]
 
-    arg_tmps <- mapM assignTemp arg_exprs
+    arg_tmps <- sequence [
+                 if isFollowableArg (typeCgRep (stgArgType stg_arg))
+                 then assignPtrTemp arg
+                 else assignNonPtrTemp arg
+                     | (arg, stg_arg) <- arg_exprs]
     let	arg_hints = zip arg_tmps (map (typeHint.stgArgType) stg_args)
     {-
 	Now, allocate some result regs.
     -}
     (res_reps,res_regs,res_hints)  <- newUnboxedTupleRegs res_ty
-    ccallReturnUnboxedTuple (zip res_reps (map CmmReg res_regs)) $
+    ccallReturnUnboxedTuple (zip res_reps (map (CmmReg . CmmLocal) res_regs)) $
 	emitForeignCall (zip res_regs res_hints) fcall 
 	   arg_hints emptyVarSet{-no live vars-}
       
@@ -136,8 +140,11 @@ cgExpr (StgOpApp (StgFCallOp fcall _) stg_args res_ty) = do
 
 cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) 
   = ASSERT(isEnumerationTyCon tycon)
-    do	{ (_,amode) <- getArgAmode arg
-	; amode' <- assignTemp amode	-- We're going to use it twice,
+    do	{ (rep,amode) <- getArgAmode arg
+	; amode' <- if isFollowableArg rep
+                    then assignPtrTemp amode
+	            else assignNonPtrTemp amode
+					-- We're going to use it twice,
 					-- so save in a temp if non-trivial
 	; this_pkg <- getThisPackage
 	; stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon amode'))
@@ -160,21 +167,27 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty)
 	     performReturn emitReturnInstr
 
   | ReturnsPrim rep <- result_info
-	= do cgPrimOp [dataReturnConvPrim (primRepToCgRep rep)] 
-			primop args emptyVarSet
+	= do res <- if isFollowableArg (typeCgRep res_ty)
+                        then newPtrTemp (argMachRep (typeCgRep res_ty))
+                        else newNonPtrTemp (argMachRep (typeCgRep res_ty))
+             cgPrimOp [res] primop args emptyVarSet
 	     performPrimReturn (primRepToCgRep rep) (CmmReg (CmmLocal res))
 
   | ReturnsAlg tycon <- result_info, isUnboxedTupleTyCon tycon
 	= do (reps, regs, _hints) <- newUnboxedTupleRegs res_ty
 	     cgPrimOp regs primop args emptyVarSet{-no live vars-}
-	     returnUnboxedTuple (zip reps (map CmmReg regs))
+	     returnUnboxedTuple (zip reps (map (CmmReg . CmmLocal) regs))
 
   | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon
 	-- c.f. cgExpr (...TagToEnumOp...)
-	= do tag_reg <- newTemp wordRep
+	= do tag_reg <- if isFollowableArg (typeCgRep res_ty)
+                        then newPtrTemp wordRep
+                        else newNonPtrTemp wordRep
 	     this_pkg <- getThisPackage
 	     cgPrimOp [tag_reg] primop args emptyVarSet
-	     stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon (CmmReg tag_reg)))
+	     stmtC (CmmAssign nodeReg
+                    (tagToClosure this_pkg tycon
+                     (CmmReg (CmmLocal tag_reg))))
 	     performReturn emitReturnInstr
   where
 	result_info = getPrimOpResultInfo primop
@@ -438,14 +451,17 @@ cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
 Little helper for primitives that return unboxed tuples.
 
 \begin{code}
-newUnboxedTupleRegs :: Type -> FCode ([CgRep], [CmmReg], [MachHint])
+newUnboxedTupleRegs :: Type -> FCode ([CgRep], [LocalReg], [MachHint])
 newUnboxedTupleRegs res_ty =
    let
 	ty_args = tyConAppArgs (repType res_ty)
-	(reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args, 
+	(reps,hints) = unzip [ (rep, typeHint ty) | ty <- ty_args,
 					   	    let rep = typeCgRep ty,
 					 	    nonVoidArg rep ]
+	make_new_temp rep = if isFollowableArg rep
+                            then newPtrTemp (argMachRep rep)
+                            else newNonPtrTemp (argMachRep rep)
    in do
-   regs <- mapM (newTemp . argMachRep) reps
+   regs <- mapM make_new_temp reps
    return (reps,regs,hints)
 \end{code}

compiler/codeGen/CgForeignCall.hs

@@ -48,7 +48,7 @@ import Control.Monad
 -- Code generation for Foreign Calls
 
 cgForeignCall
-	:: [(CmmReg,MachHint)]	-- where to put the results
+	:: CmmHintFormals	-- where to put the results
 	-> ForeignCall		-- the op
 	-> [StgArg]		-- arguments
 	-> StgLiveVars	-- live vars, in case we need to save them
@@ -68,7 +68,7 @@ cgForeignCall results fcall stg_args live
 
 
 emitForeignCall
-	:: [(CmmReg,MachHint)]	-- where to put the results
+	:: CmmHintFormals	-- where to put the results
 	-> ForeignCall		-- the op
 	-> [(CmmExpr,MachHint)] -- arguments
 	-> StgLiveVars	-- live vars, in case we need to save them
@@ -103,7 +103,7 @@ emitForeignCall results (DNCall _) args live
 -- alternative entry point, used by CmmParse
 emitForeignCall'
 	:: Safety
-	-> [(CmmReg,MachHint)]	-- where to put the results
+	-> CmmHintFormals	-- where to put the results
 	-> CmmCallTarget	-- the op
 	-> [(CmmExpr,MachHint)] -- arguments
 	-> Maybe [GlobalReg]	-- live vars, in case we need to save them
@@ -117,24 +117,27 @@ emitForeignCall' safety results target args vols
     stmtsC caller_load
 
   | otherwise = do
-    id <- newTemp wordRep
+    -- Both 'id' and 'new_base' are KindNonPtr because they're