X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmParse.y;h=579df5e8ab21d4feb37710111b2e6cd57903fdab;hb=d55027c917a101692ded11b6b1421052866df2d4;hp=2cf1d1d821ab94dc71e0d78d50fb196e67d1aff7;hpb=b47302cbee70802076638ee58fe1c00853eae10a;p=ghc-hetmet.git

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 2cf1d1d..579df5e 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -201,21 +201,21 @@ lits	:: { [ExtFCode CmmExpr] }
 cmmproc :: { ExtCode }
 -- TODO: add real SRT/info tables to parsed Cmm
 	: info maybe_formals maybe_frame maybe_gc_block '{' body '}'
-		{ do ((info_lbl, info, live, formals, frame, gc_block), stmts) <-
+		{ do ((entry_ret_label, info, live, formals, frame, gc_block), stmts) <-
 		       getCgStmtsEC' $ loopDecls $ do {
-		         (info_lbl, info, live) <- $1;
+		         (entry_ret_label, info, live) <- $1;
 		         formals <- sequence $2;
 		         frame <- $3;
 		         gc_block <- $4;
 		         $6;
-		         return (info_lbl, info, live, formals, frame, gc_block) }
+		         return (entry_ret_label, info, live, formals, frame, gc_block) }
 		     blks <- code (cgStmtsToBlocks stmts)
-		     code (emitInfoTableAndCode info_lbl (CmmInfo gc_block frame info) formals blks) }
+		     code (emitInfoTableAndCode entry_ret_label (CmmInfo gc_block frame info) formals blks) }
 
 	| info maybe_formals ';'
-		{ do (info_lbl, info, live) <- $1;
+		{ do (entry_ret_label, info, live) <- $1;
 		     formals <- sequence $2;
-		     code (emitInfoTableAndCode info_lbl (CmmInfo Nothing Nothing info) formals []) }
+		     code (emitInfoTableAndCode entry_ret_label (CmmInfo Nothing Nothing info) formals []) }
 
 	| NAME maybe_formals maybe_frame maybe_gc_block '{' body '}'
 		{ do ((formals, frame, gc_block), stmts) <-
@@ -232,7 +232,7 @@ info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 	: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- ptrs, nptrs, closure type, description, type
 		{ do prof <- profilingInfo $11 $13
-		     return (mkRtsInfoLabelFS $3,
+		     return (mkRtsEntryLabelFS $3,
 			CmmInfoTable prof (fromIntegral $9)
 				     (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT),
 			[]) }
@@ -240,7 +240,7 @@ info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 	| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
 		-- ptrs, nptrs, closure type, description, type, fun type
 		{ do prof <- profilingInfo $11 $13
-		     return (mkRtsInfoLabelFS $3,
+		     return (mkRtsEntryLabelFS $3,
 			CmmInfoTable prof (fromIntegral $9)
 				     (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
 				      (ArgSpec 0)
@@ -255,7 +255,7 @@ info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 		     -- If profiling is on, this string gets duplicated,
 		     -- but that's the way the old code did it we can fix it some other time.
 		     desc_lit <- code $ mkStringCLit $13
-		     return (mkRtsInfoLabelFS $3,
+		     return (mkRtsEntryLabelFS $3,
 			CmmInfoTable prof (fromIntegral $11)
 				     (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit),
 			[]) }
@@ -263,14 +263,15 @@ info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 	| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
 		-- selector, closure type, description, type
 		{ do prof <- profilingInfo $9 $11
-		     return (mkRtsInfoLabelFS $3,
+		     return (mkRtsEntryLabelFS $3,
 			CmmInfoTable prof (fromIntegral $7)
 				     (ThunkSelectorInfo (fromIntegral $5) NoC_SRT),
 			[]) }
 
 	| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
 		-- closure type (no live regs)
-		{ return (mkRtsInfoLabelFS $3,
+		{ do let infoLabel = mkRtsInfoLabelFS $3
+		     return (mkRtsRetLabelFS $3,
 			CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
 				     (ContInfo [] NoC_SRT),
 			[]) }
@@ -278,7 +279,7 @@ info	:: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
 	| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
 		-- closure type, live regs
 		{ do live <- sequence (map (liftM Just) $7)
-		     return (mkRtsInfoLabelFS $3,
+		     return (mkRtsRetLabelFS $3,
 			CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5)
 			             (ContInfo live NoC_SRT),
 			live) }
@@ -293,7 +294,7 @@ decl	:: { ExtCode }
 	| STRING type names ';'		{% do k <- parseKind $1;
 					      return $ mapM_ (newLocal k $2) $3 }
 
-	| 'import' names ';'		{ return () }  -- ignore imports
+	| 'import' names ';'		{ mapM_ newImport $2 }
 	| 'export' names ';'		{ return () }  -- ignore exports
 
 names 	:: { [FastString] }
@@ -769,9 +770,12 @@ instance Monad ExtFCode where
 -- an environment, which is looped back into the computation.  In this
 -- way, we can have embedded declarations that scope over the whole
 -- procedure, and imports that scope over the entire module.
+-- Discards the local declaration contained within decl'
 loopDecls :: ExtFCode a -> ExtFCode a
-loopDecls (EC fcode) = 
-   EC $ \e s -> fixC (\ ~(decls,a) -> fcode (addListToUFM e decls) [])
+loopDecls (EC fcode) =
+      EC $ \e globalDecls -> do
+	(decls', a) <- fixC (\ ~(decls,a) -> fcode (addListToUFM e (decls ++ globalDecls)) globalDecls)
+	return (globalDecls, a)
 
 getEnv :: ExtFCode Env
 getEnv = EC $ \e s -> return (s, e)
@@ -789,6 +793,13 @@ newLocal kind ty name = do
    addVarDecl name (CmmReg (CmmLocal reg))
    return reg
 
+-- Creates a foreign label in the import. CLabel's labelDynamic
+-- classifies these labels as dynamic, hence the code generator emits the
+-- PIC code for them.
+newImport :: FastString -> ExtFCode ()
+newImport name =
+       addVarDecl name (CmmLit (CmmLabel (mkForeignLabel name Nothing True)))
+
 newLabel :: FastString -> ExtFCode BlockId
 newLabel name = do
    u <- code newUnique