X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fcmm%2FCmmParse.y;h=cfb2a9d93cd203264cf9165caf9ac9a0aa233d54;hb=174c7f292b3c18c9cc44c21bd07111f351e3913c;hp=e409f25d583de9cda7de091f2e0b48bafc61cc05;hpb=423d477bfecd490de1449c59325c8776f91d7aac;p=ghc-hetmet.git

diff --git a/ghc/compiler/cmm/CmmParse.y b/ghc/compiler/cmm/CmmParse.y
index e409f25..cfb2a9d 100644
--- a/ghc/compiler/cmm/CmmParse.y
+++ b/ghc/compiler/cmm/CmmParse.y
@@ -25,11 +25,11 @@ import CostCentre	( dontCareCCS )
 
 import Cmm
 import PprCmm
-import CmmUtils		( mkIntCLit, mkLblExpr )
+import CmmUtils		( mkIntCLit )
 import CmmLex
 import CLabel
 import MachOp
-import SMRep		( tablesNextToCode, fixedHdrSize, CgRep(..) )
+import SMRep		( fixedHdrSize, CgRep(..) )
 import Lexer
 
 import ForeignCall	( CCallConv(..) )
@@ -37,7 +37,9 @@ import Literal		( mkMachInt )
 import Unique
 import UniqFM
 import SrcLoc
-import CmdLineOpts	( DynFlags, DynFlag(..), opt_SccProfilingOn )
+import DynFlags		( DynFlags, DynFlag(..) )
+import Packages		( HomeModules )
+import StaticFlags	( opt_SccProfilingOn )
 import ErrUtils		( printError, dumpIfSet_dyn, showPass )
 import StringBuffer	( hGetStringBuffer )
 import FastString
@@ -46,6 +48,7 @@ import Constants	( wORD_SIZE )
 import Outputable
 
 import Monad		( when )
+import Data.Char	( ord )
 
 #include "HsVersions.h"
 }
@@ -175,7 +178,7 @@ static 	:: { ExtFCode [CmmStatic] }
 			     return [CmmStaticLit (getLit e)] }
 	| type ';'			{ return [CmmUninitialised
 							(machRepByteWidth $1)] }
-        | 'bits8' '[' ']' STRING ';'	{ return [CmmString $4] }
+        | 'bits8' '[' ']' STRING ';'	{ return [mkString $4] }
         | 'bits8' '[' INT ']' ';'	{ return [CmmUninitialised 
 							(fromIntegral $3)] }
         | typenot8 '[' INT ']' ';'	{ return [CmmUninitialised 
@@ -186,7 +189,7 @@ static 	:: { ExtFCode [CmmStatic] }
 		{ do lits <- sequence $4;
 		     return $ map CmmStaticLit $
 		       mkStaticClosure (mkRtsInfoLabelFS $3) 
-			 dontCareCCS (map getLit lits) [] [] }
+			 dontCareCCS (map getLit lits) [] [] [] }
 	-- arrays of closures required for the CHARLIKE & INTLIKE arrays
 
 lits	:: { [ExtFCode CmmExpr] }
@@ -229,9 +232,9 @@ info	:: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
 	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' INT ',' INT maybe_vec ')'
 		{ retInfo $3 $5 $7 $9 $10 }
 
-maybe_vec :: { [CLabel] }
+maybe_vec :: { [CmmLit] }
 	: {- empty -}			{ [] }
-	| ',' NAME maybe_vec		{ mkRtsCodeLabelFS $2 : $3 }
+	| ',' NAME maybe_vec		{ CmmLabel (mkRtsCodeLabelFS $2) : $3 }
 
 body	:: { ExtCode }
 	: {- empty -}			{ return () }
@@ -293,6 +296,7 @@ bool_op :: { ExtFCode BoolExpr }
 -- This is not C-- syntax.  What to do?
 vols 	:: { Maybe [GlobalReg] }
 	: {- empty -}			{ Nothing }
+	| '[' ']'		        { Just [] }
 	| '[' globals ']'		{ Just $2 }
 
 globals :: { [GlobalReg] }
@@ -424,6 +428,9 @@ section "rodata" = ReadOnlyData
 section "bss"	 = UninitialisedData
 section s	 = OtherSection s
 
+mkString :: String -> CmmStatic
+mkString s = CmmString (map (fromIntegral.ord) s)
+
 -- 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
@@ -464,7 +471,7 @@ exprMacros = listToUFM [
   ( FSLIT("INFO_TYPE"),    \ [x] -> infoTableClosureType x ),
   ( FSLIT("INFO_PTRS"),    \ [x] -> infoTablePtrs x ),
   ( FSLIT("INFO_NPTRS"),   \ [x] -> infoTableNonPtrs x ),
-  ( FSLIT("RET_VEC"),      \ [info, conZ] -> CmmLoad (vectorSlot info conZ) wordRep )
+  ( FSLIT("RET_VEC"),      \ [info, conZ] -> retVec info conZ )
   ]
 
 -- we understand a subset of C-- primitives:
@@ -677,9 +684,10 @@ forkLabelledCodeEC ec = do
 
 retInfo name size live_bits cl_type vector = do
   let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
-      (info1,info2) = mkRetInfoTable liveness NoC_SRT 
+      info_lbl = mkRtsRetInfoLabelFS name
+      (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT 
 				(fromIntegral cl_type) vector
-  return (mkRtsRetInfoLabelFS name, info1, info2)
+  return (info_lbl, info1, info2)
 
 stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
   basicInfo name (packHalfWordsCLit ptrs nptrs) 
@@ -711,7 +719,7 @@ funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
 staticClosure :: FastString -> FastString -> [CmmLit] -> ExtCode
 staticClosure cl_label info payload
   = code $ emitDataLits (mkRtsDataLabelFS cl_label) lits
-  where  lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] []
+  where  lits = mkStaticClosure (mkRtsInfoLabelFS info) dontCareCCS payload [] [] []
 
 foreignCall
 	:: String
@@ -854,11 +862,13 @@ doSwitch mb_range scrut arms deflt
 initEnv :: Env
 initEnv = listToUFM [
   ( FSLIT("SIZEOF_StgHeader"), 
-	CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) )
+	CmmLit (CmmInt (fromIntegral (fixedHdrSize * wORD_SIZE)) wordRep) ),
+  ( FSLIT("SIZEOF_StgInfoTable"),
+        CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) )
   ]
 
-parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm)
-parseCmmFile dflags filename = do
+parseCmmFile :: DynFlags -> HomeModules -> FilePath -> IO (Maybe Cmm)
+parseCmmFile dflags hmods filename = do
   showPass dflags "ParseCmm"
   buf <- hGetStringBuffer filename
   let
@@ -869,10 +879,9 @@ parseCmmFile dflags filename = do
   case unP cmmParse init_state of
     PFailed span err -> do printError span err; return Nothing
     POk _ code -> do
-	cmm <- initC no_module (getCmm (unEC code initEnv [] >> return ()))
+	cmm <- initC dflags hmods no_module (getCmm (unEC code initEnv [] >> return ()))
 	dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
 	return (Just cmm)
   where
 	no_module = panic "parseCmmFile: no module"
-
 }