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.

8 files changed, 94 insertions, 66 deletions

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 986f486cc7..cae1633366 100644
--- a/compiler/cmm/Cmm.hs
+++ b/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
diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs
index 49c41bb7bc..1d07631755 100644
--- a/compiler/cmm/CmmBrokenBlock.hs
+++ b/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)
diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index 4d90a4d432..9a9f8a9fb2 100644
--- a/compiler/cmm/CmmCPS.hs
+++ b/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))
 
diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs
index b379f2db3c..40d7b7c82e 100644
--- a/compiler/cmm/CmmLive.hs
+++ b/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
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index aa5a788d5e..aa0c821809 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/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
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 6048c44d12..567dd606ad 100644
--- a/compiler/cmm/CmmParse.y
+++ b/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
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index d9bdca5b83..bda191cb5f 100644
--- a/compiler/cmm/PprC.hs
+++ b/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
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 4ade7a4028..ee8f0f3040 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/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
 --