From: wolfgang.thaller@gmx.net <unknown>
Date: Sun, 22 Oct 2006 16:05:07 +0000 (+0000)
Subject: Cast switch scrutinees to W_ in AutoApply.cmm
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=4f6f4a294f00d559b4f024255d11eb1da9bfe036

Cast switch scrutinees to W_ in AutoApply.cmm

... and make CmmLint check for this problem.
This doesn't matter for -fvia-C, but passing a halfword to a switch
will make the NCG generate crashing code.
---

diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs
index 632337f..875876f 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/cmm/CmmLint.hs
@@ -119,7 +119,11 @@ lintCmmStmt (CmmStore l r) = do
   return ()
 lintCmmStmt (CmmCall _target _res args _vols) = mapM_ (lintCmmExpr.fst) args
 lintCmmStmt (CmmCondBranch e _id)   = lintCmmExpr e >> checkCond e >> return ()
-lintCmmStmt (CmmSwitch e _branches) = lintCmmExpr e >> return ()
+lintCmmStmt (CmmSwitch e _branches) = do
+  erep <- lintCmmExpr e
+  if (erep == wordRep)
+    then return ()
+    else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
 lintCmmStmt (CmmJump e _args)       = lintCmmExpr e >> return ()
 lintCmmStmt _other 		    = return ()
 
diff --git a/utils/genapply/GenApply.hs b/utils/genapply/GenApply.hs
index cdde66f..6827703 100644
--- a/utils/genapply/GenApply.hs
+++ b/utils/genapply/GenApply.hs
@@ -414,7 +414,7 @@ genApply regstatus args =
 --    if fast == 1:
 --        print "    goto *lbls[info->type];";
 --    else:
-        text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (%INFO_TYPE(%STD_INFO(info))) {",
+        text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(%STD_INFO(info)))) {",
 	nest 4 (vcat [
 
 --    if fast == 1:
@@ -540,7 +540,7 @@ genApplyFast regstatus args =
         text "W_ info;",
         text "W_ arity;",
         text  "info = %GET_STD_INFO(R1);",
-        text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (%INFO_TYPE(info)) {",
+        text "switch [INVALID_OBJECT .. N_CLOSURE_TYPES] (TO_W_(%INFO_TYPE(info))) {",
 	nest 4 (vcat [
           text "case FUN,",
           text "     FUN_1_0,",