From: sof <unknown>
Date: Fri, 29 Mar 2002 21:39:39 +0000 (+0000)
Subject: [project @ 2002-03-29 21:39:36 by sof]
X-Git-Tag: Approx_11550_changesets_converted~2203
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=76293b141bba4c15a6fd619dd980502e98614790;p=ghc-hetmet.git

[project @ 2002-03-29 21:39:36 by sof]
Front end for External Core.

Initial go at implementing a Core front end
(enabled via -fcore); work in progress (renamer
is currently not willing to slurp in & resolve
imports.)
---

diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index 5cece7a..07f8f32 100644
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -54,11 +54,12 @@ deSugar :: DynFlags
 	-> IO (ModDetails, (SDoc, SDoc, [FAST_STRING], [CoreBndr]))
 
 deSugar dflags pcs hst mod_name unqual
-        (TcResults {tc_env   = type_env,
-		    tc_binds = all_binds,
-		    tc_insts = insts,
-		    tc_rules = rules,
-		    tc_fords = fo_decls})
+        (TcResults {tc_env    = type_env,
+		    tc_binds  = all_binds,
+		    tc_insts  = insts,
+		    tc_rules  = rules,
+		    tc_cbinds = core_binds,
+		    tc_fords  = fo_decls})
   = do	{ showPass dflags "Desugar"
 	; us <- mkSplitUniqSupply 'd'
 
@@ -67,11 +68,16 @@ deSugar dflags pcs hst mod_name unqual
 					     (dsProgram mod_name all_binds rules fo_decls)    
 
 	      (ds_binds, ds_rules, foreign_stuff) = ds_result
+	      
+	      addCoreBinds ls =
+	        case core_binds of
+		  [] -> ls
+		  cs -> (Rec cs) : ls
 	
 	      mod_details = ModDetails { md_types = type_env,
 					 md_insts = insts,
 					 md_rules = ds_rules,
-					 md_binds = ds_binds }
+					 md_binds = addCoreBinds ds_binds }
 
 	-- Display any warnings
         ; doIfSet (not (isEmptyBag ds_warns))
diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs
index 4c0ed19..8d1da8f 100644
--- a/ghc/compiler/hsSyn/HsCore.lhs
+++ b/ghc/compiler/hsSyn/HsCore.lhs
@@ -14,8 +14,8 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and
 module HsCore (
 	UfExpr(..), UfAlt, UfBinder(..), UfNote(..),
 	UfBinding(..), UfConAlt(..),
-	HsIdInfo(..), pprHsIdInfo, 
-
+	HsIdInfo(..), pprHsIdInfo,
+	
 	eq_ufExpr, eq_ufBinders, pprUfExpr, pprHsIdInfo,
 
 	toUfExpr, toUfBndr, ufBinderName
diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs
index 061ee4f..f6b0e9f 100644
--- a/ghc/compiler/hsSyn/HsDecls.lhs
+++ b/ghc/compiler/hsSyn/HsDecls.lhs
@@ -17,7 +17,8 @@ module HsDecls (
 	DeprecDecl(..), DeprecTxt,
 	hsDeclName, instDeclName, 
 	tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
-	isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
+	isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, isCoreDecl,
+	countTyClDecls,
 	mkClassDeclSysNames, isSourceInstDecl, ifaceRuleDeclName,
 	getClassDeclSysNames, conDetailsTys,
 	collectRuleBndrSigTys
@@ -302,12 +303,19 @@ data TyClDecl name pat
 		tcdSysNames :: ClassSysNames name,
 		tcdLoc      :: SrcLoc
     }
+    -- a Core value binding (coming from 'external Core' input.)
+  | CoreDecl { tcdName      :: name,  
+               tcdType      :: HsType name,
+	       tcdRhs       :: UfExpr name,
+	       tcdLoc       :: SrcLoc
+    }
+
 \end{code}
 
 Simple classifiers
 
 \begin{code}
-isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
+isIfaceSigDecl, isCoreDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool
 
 isIfaceSigDecl (IfaceSig {}) = True
 isIfaceSigDecl other	     = False
@@ -320,6 +328,10 @@ isDataDecl other       = False
 
 isClassDecl (ClassDecl {}) = True
 isClassDecl other	   = False
+
+isCoreDecl (CoreDecl {}) = True
+isCoreDecl other	 = False
+
 \end{code}
 
 Dealing with names
@@ -338,6 +350,7 @@ tyClDeclNames :: Eq name => TyClDecl name pat -> [(name, SrcLoc)]
 
 tyClDeclNames (TySynonym   {tcdName = name, tcdLoc = loc})  = [(name,loc)]
 tyClDeclNames (IfaceSig    {tcdName = name, tcdLoc = loc})  = [(name,loc)]
+tyClDeclNames (CoreDecl    {tcdName = name, tcdLoc = loc})  = [(name,loc)]
 tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc})  = [(name,loc)]
 
 tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc})
@@ -352,6 +365,7 @@ tyClDeclTyVars (TyData    {tcdTyVars = tvs}) = tvs
 tyClDeclTyVars (ClassDecl {tcdTyVars = tvs}) = tvs
 tyClDeclTyVars (ForeignType {})		     = []
 tyClDeclTyVars (IfaceSig {})		     = []
+tyClDeclTyVars (CoreDecl {})		     = []
 
 
 --------------------------------
@@ -396,6 +410,11 @@ instance (NamedThing name, Ord name) => Eq (TyClDecl name pat) where
 	tcdType d1 == tcdType d2 && 
 	tcdIdInfo d1 == tcdIdInfo d2
 
+  (==) d1@(CoreDecl {}) d2@(CoreDecl {})
+      = tcdName d1 == tcdName d2 && 
+	tcdType d1 == tcdType d2 && 
+	tcdRhs d1  == tcdRhs  d2
+
   (==) d1@(ForeignType {}) d2@(ForeignType {})
       = tcdName d1 == tcdName d2 && 
 	tcdFoType d1 == tcdFoType d2
@@ -453,7 +472,7 @@ countTyClDecls :: [TyClDecl name pat] -> (Int, Int, Int, Int, Int)
 countTyClDecls decls 
  = (count isClassDecl     decls,
     count isSynDecl       decls,
-    count isIfaceSigDecl  decls,
+    count (\ x -> isIfaceSigDecl x || isCoreDecl x) decls,
     count isDataTy        decls,
     count isNewTy         decls) 
  where
@@ -506,6 +525,10 @@ instance (NamedThing name, Outputable name, Outputable pat)
 			then empty
 			else ppr (fromJust methods)
         
+    ppr (CoreDecl {tcdName = var, tcdType = ty, tcdRhs = rhs})
+	= getPprStyle $ \ sty ->
+	   hsep [ ppr_var var, dcolon, ppr ty, ppr rhs ]
+
 pp_decl_head :: Outputable name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc
 pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars]
 
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs
index 2589fd0..c054f0d 100644
--- a/ghc/compiler/main/CmdLineOpts.lhs
+++ b/ghc/compiler/main/CmdLineOpts.lhs
@@ -332,6 +332,7 @@ data HscLang
   | HscAsm
   | HscJava
   | HscILX
+  | HscCore
   | HscInterpreted
   | HscNothing
     deriving (Eq, Show)
diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs
index 12c399d..713b287 100644
--- a/ghc/compiler/main/DriverFlags.hs
+++ b/ghc/compiler/main/DriverFlags.hs
@@ -1,7 +1,7 @@
 {-# OPTIONS -#include "hschooks.h" #-}
 
 -----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.89 2002/03/15 13:57:31 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.90 2002/03/29 21:39:37 sof Exp $
 --
 -- Driver flags
 --
@@ -432,6 +432,7 @@ dynamic_flags = [
   ,  ( "fvia-c",	NoArg (setLang HscC) )
   ,  ( "fvia-C",	NoArg (setLang HscC) )
   ,  ( "filx",		NoArg (setLang HscILX) )
+  ,  ( "fcore",		NoArg (setLang HscCore) )
 
 	-- "active negatives"
   ,  ( "fno-implicit-prelude",  NoArg (setDynFlag Opt_NoImplicitPrelude) )
diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs
index 6434495..53746e9 100644
--- a/ghc/compiler/main/DriverPhases.hs
+++ b/ghc/compiler/main/DriverPhases.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverPhases.hs,v 1.16 2002/03/04 17:01:30 simonmar Exp $
+-- $Id: DriverPhases.hs,v 1.17 2002/03/29 21:39:37 sof Exp $
 --
 -- GHC Driver
 --
@@ -64,6 +64,7 @@ startPhase "lhs"   = Unlit
 startPhase "hs"    = Cpp
 startPhase "hscpp" = HsPp
 startPhase "hspp"  = Hsc
+startPhase "hcr"   = Hsc
 startPhase "hs-boot" = HsBoot
 startPhase "hc"    = HCc
 startPhase "c"     = Cc
@@ -97,8 +98,8 @@ phaseInputExt Ilx2Il      = "ilx"
 phaseInputExt Ilasm       = "il"
 #endif
 
-haskellish_suffix     = (`elem` [ "hs", "hspp", "hscpp", "lhs", "hc", "raw_s" ])
-haskellish_src_suffix = (`elem` [ "hs", "hspp", "hscpp", "lhs" ])
+haskellish_suffix     = (`elem` [ "hs", "lhs", "hspp", "hscpp", "hcr", "hc", "raw_s" ])
+haskellish_src_suffix = (`elem` [ "hs", "lhs", "hspp", "hscpp", "hcr"])
 cish_suffix           = (`elem` [ "c", "cpp", "C", "cc", "cxx", "s", "S" ])
 hsbootish_suffix      = (`elem` [ "hs-boot" ])
 
diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index fb98729..7dd690a 100644
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -152,6 +152,11 @@ genPipeline todo stop_flag persistent_output lang (filename,suffix)
 	        | split	       	  -> not_valid
 	        | otherwise       -> [ Hsc, HCc, As ]
 
+	HscCore | split && mangle -> [ Hsc, HCc, Mangle, SplitMangle, SplitAs ]
+	        | mangle          -> [ Hsc, HCc, Mangle, As ]
+	        | split	       	  -> not_valid
+	        | otherwise       -> [ Hsc, HCc, As ]
+
 	HscAsm  | split           -> [ Hsc, SplitMangle, SplitAs ]
 	        | otherwise       -> [ Hsc, As ]
 
@@ -187,9 +192,12 @@ genPipeline todo stop_flag persistent_output lang (filename,suffix)
 	-- something has gone wrong.  This test carefully avoids the
 	-- case where we aren't supposed to do any compilation, because the file
 	-- is already in linkable form (for example).
+--   hPutStrLn stderr (show ((start_phase `elem` pipeline,stop_phase /= Ln,stop_phase `notElem` pipeline), start_phase, stop_phase, pipeline,todo))
+--   hFlush stderr
    when (start_phase `elem` pipeline && 
    	 (stop_phase /= Ln && stop_phase `notElem` pipeline))
-        (throwDyn (UsageError 
+        (do
+	  throwDyn (UsageError 
 		    ("flag `" ++ stop_flag
 		     ++ "' is incompatible with source file `"
 		     ++ filename ++ "'" ++ show pipeline ++ show stop_phase)))
diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs
index 01b03e8..6d15663 100644
--- a/ghc/compiler/main/DriverState.hs
+++ b/ghc/compiler/main/DriverState.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.73 2002/03/29 20:14:31 krasimir Exp $
+-- $Id: DriverState.hs,v 1.74 2002/03/29 21:39:37 sof Exp $
 --
 -- Settings for the driver
 --
@@ -44,7 +44,7 @@ data GhcMode
   | DoMake				-- ghc --make
   | DoInteractive			-- ghc --interactive
   | DoLink				-- [ the default ]
-  deriving (Eq)
+  deriving (Eq,Show)
 
 GLOBAL_VAR(v_GhcMode,     DoLink, GhcMode)
 GLOBAL_VAR(v_GhcModeFlag, "",     String)
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 243844a..af0d944 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -92,6 +92,9 @@ import Maybe		( isJust, fromJust )
 import IO
 
 import MkExternalCore	( emitExternalCore )
+import ParserCore
+import ParserCoreUtils
+
 \end{code}
 
 
@@ -424,7 +427,13 @@ myParseModule dflags src_filename
  = do --------------------------  Parser  ----------------
       showPass dflags "Parser"
       _scc_  "Parser" do
-
+      if dopt_HscLang dflags == HscCore 
+       then do
+         inp <- readFile src_filename
+	 case parseCore inp 1 of
+	   OkP m   -> return (Just m)
+	   FailP s -> hPutStrLn stderr s >> return Nothing
+       else do
       buf <- hGetStringBuffer src_filename
 
       let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags,
diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index a5d8c64..ee84cd0 100644
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -1,7 +1,7 @@
 {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-}
 
 -----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.101 2002/03/26 22:08:44 sof Exp $
+-- $Id: Main.hs,v 1.102 2002/03/29 21:39:37 sof Exp $
 --
 -- GHC Driver program
 --
@@ -280,15 +280,19 @@ main =
 	  let not_hs_file  = not (haskellish_src_file src)
 	  pp <- if not_hs_file || mode == StopBefore Hsc || mode == StopBefore HsPp
 			then return src_and_suff else do
+--		hPutStrLn stderr "before" >> hFlush stderr
 		phases <- genPipeline (StopBefore Hsc) stop_flag
 				      False{-not persistent-} defaultHscLang
 				      src_and_suff
+--		hPutStrLn stderr "after" >> hFlush stderr
 	  	pipeLoop phases src_and_suff False{-no linking-} False{-no -o flag-}
 			basename suffix
 
 	  -- rest of compilation
 	  hsc_lang <- dynFlag hscLang
+--	  hPutStrLn stderr ("before-1 " ++ show (pp,mode)) >> hFlush stderr
 	  phases   <- genPipeline mode stop_flag True hsc_lang pp
+--	  hPutStrLn stderr "after" >> hFlush stderr
 	  (r,_)    <- pipeLoop phases pp (mode==DoLink || mode==DoMkDLL)
 	  			      True{-use -o flag-} basename suffix
 	  return r
diff --git a/ghc/compiler/parser/LexCore.hs b/ghc/compiler/parser/LexCore.hs
new file mode 100644
index 0000000..2a91683
--- /dev/null
+++ b/ghc/compiler/parser/LexCore.hs
@@ -0,0 +1,92 @@
+module LexCore where
+
+import ParserCoreUtils
+import Ratio
+import Char
+
+isNameChar c = isAlpha c || isDigit c || (c == '_') || (c == '\'') 
+isKeywordChar c = isAlpha c || (c == '_') 
+
+lexer :: (Token -> P a) -> P a 
+lexer cont [] = cont TKEOF []
+lexer cont ('\n':cs) = \line -> lexer cont cs (line+1)
+lexer cont ('-':'>':cs) = cont TKrarrow cs
+lexer cont (c:cs) 
+      | isSpace c = lexer cont cs
+      | isLower c || (c == '_') = lexName cont TKname (c:cs)
+      | isUpper c = lexName cont TKcname (c:cs)
+      | isDigit c || (c == '-') = lexNum cont (c:cs)
+lexer cont ('%':cs) = lexKeyword cont cs
+lexer cont ('\'':cs) = lexChar cont cs
+lexer cont ('\"':cs) = lexString [] cont cs 
+lexer cont ('#':cs) = cont TKhash cs
+lexer cont ('(':cs) = cont TKoparen cs
+lexer cont (')':cs) = cont TKcparen cs
+lexer cont ('{':cs) = cont TKobrace cs
+lexer cont ('}':cs) = cont TKcbrace cs
+lexer cont ('=':cs) = cont TKeq cs
+lexer cont (':':':':cs) = cont TKcoloncolon cs
+lexer cont ('*':cs) = cont TKstar cs
+lexer cont ('.':cs) = cont TKdot cs
+lexer cont ('\\':cs) = cont TKlambda cs
+lexer cont ('@':cs) = cont TKat cs
+lexer cont ('?':cs) = cont TKquestion cs
+lexer cont (';':cs) = cont TKsemicolon cs
+lexer cont (c:cs) = failP "invalid character" [c]
+
+lexChar cont ('\\':'x':h1:h0:'\'':cs)
+	| isHexEscape [h1,h0] =  cont (TKchar (hexToChar h1 h0)) cs
+lexChar cont ('\\':cs) = failP "invalid char character" ('\\':(take 10 cs))
+lexChar cont ('\'':cs) = failP "invalid char character" ['\'']
+lexChar cont ('\"':cs) = failP "invalid char character" ['\"']
+lexChar cont (c:'\'':cs) = cont (TKchar c) cs
+
+lexString s cont ('\\':'x':h1:h0:cs) 
+	| isHexEscape [h1,h0] = lexString (s++[hexToChar h1 h0]) cont cs
+lexString s cont ('\\':cs) = failP "invalid string character" ['\\']
+lexString s cont ('\'':cs) = failP "invalid string character" ['\'']
+lexString s cont ('\"':cs) = cont (TKstring s) cs
+lexString s cont (c:cs) = lexString (s++[c]) cont cs
+
+isHexEscape = all (\c -> isHexDigit c && (isDigit c || isLower c))
+
+hexToChar h1 h0 = 
+	chr(
+	(digitToInt h1) * 16 + 
+	(digitToInt h0))
+
+
+lexNum cont cs =
+  case cs of
+     ('-':cs) ->  f (-1) cs
+     _ -> f 1 cs
+ where f sgn cs = 
+         case span isDigit cs of
+          (digits,'.':c:rest) | isDigit c -> 
+	     cont (TKrational (numer % denom)) rest'
+	       where (fpart,rest') = span isDigit (c:rest)
+		     denom = 10^(length fpart)
+		     numer = sgn * ((read digits) * denom + (read fpart))
+          (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest
+
+lexName cont cstr cs = cont (cstr name) rest
+   where (name,rest) = span isNameChar cs
+
+lexKeyword cont cs = 
+   case span isKeywordChar cs of
+      ("module",rest) -> cont TKmodule rest
+      ("import",rest) -> cont TKimport rest
+      ("data",rest)  -> cont TKdata rest
+      ("newtype",rest) -> cont TKnewtype rest
+      ("forall",rest) -> cont TKforall rest	
+      ("rec",rest) -> cont TKrec rest	
+      ("let",rest) -> cont TKlet rest	
+      ("in",rest) -> cont TKin rest	
+      ("case",rest) -> cont TKcase rest	
+      ("of",rest) -> cont TKof rest	
+      ("coerce",rest) -> cont TKcoerce rest	
+      ("note",rest) -> cont TKnote rest	
+      ("external",rest) -> cont TKexternal rest
+      ("_",rest) -> cont TKwild rest
+      _ -> failP "invalid keyword" ('%':cs) 
+
diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y
new file mode 100644
index 0000000..e4700ff
--- /dev/null
+++ b/ghc/compiler/parser/ParserCore.y
@@ -0,0 +1,251 @@
+{
+module ParserCore ( parseCore ) where
+
+import HsCore
+import RdrHsSyn
+import HsSyn
+import TyCon
+import TcType
+import RdrName
+import OccName
+import Module
+import ParserCoreUtils
+import LexCore
+import Literal
+import BasicTypes
+import Type
+import SrcLoc
+
+#include "../HsVersions.h"
+
+}
+
+%name parseCore
+%tokentype { Token }
+
+%token
+ '%module'	{ TKmodule }
+ '%import'	{ TKimport }
+ '%data'	{ TKdata }
+ '%newtype'	{ TKnewtype }
+ '%forall'	{ TKforall }
+ '%rec'		{ TKrec }
+ '%let'		{ TKlet }
+ '%in'		{ TKin }
+ '%case'	{ TKcase }
+ '%of'		{ TKof }
+ '%coerce'	{ TKcoerce }
+ '%note'	{ TKnote }
+ '%external'	{ TKexternal }
+ '%_'		{ TKwild }
+ '('		{ TKoparen }
+ ')'		{ TKcparen }
+ '{'		{ TKobrace }
+ '}'		{ TKcbrace }
+ '#' 		{ TKhash}
+ '='		{ TKeq }
+ '::'		{ TKcoloncolon }
+ '*'		{ TKstar }
+ '->'		{ TKrarrow }
+ '\\'		{ TKlambda}
+ '@'		{ TKat }
+ '.'		{ TKdot }
+ '?'		{ TKquestion}
+ ';'            { TKsemicolon }
+ NAME		{ TKname $$ }
+ CNAME 		{ TKcname $$ }
+ INTEGER	{ TKinteger $$ }
+ RATIONAL	{ TKrational $$ }
+ STRING		{ TKstring $$ }
+ CHAR		{ TKchar $$ }
+
+%monad { P } { thenP } { returnP }
+%lexer { lexer } { TKEOF }
+
+%%
+
+module	:: { RdrNameHsModule }
+	: '%module' modid imports tdefs vdefgs
+		{ HsModule $2 Nothing Nothing $3 ($4 ++ concat $5) Nothing noSrcLoc}
+
+imports :: { [ImportDecl RdrName] }
+        : {- empty -}     { [] }
+	| imp ';' imports { $1 : $3 }
+
+imp  :: { ImportDecl RdrName }
+        : '%import' modid { ImportDecl $2 ImportByUser True{-qual-} Nothing Nothing noSrcLoc }
+
+tdefs	:: { [RdrNameHsDecl] }
+	: {- empty -}	{[]}
+	| tdef ';' tdefs	{$1:$3}
+
+tdef	:: { RdrNameHsDecl }
+	: '%data' qcname tbinds '=' '{' cons1 '}'
+                { TyClD (TyData DataType [] $2 $3 (DataCons $6) Nothing [] noSrcLoc) }
+	| '%newtype' qcname tbinds trep 
+		{ TyClD (TyData NewType []  $2 $3 ($4 $2 $3) Nothing [] noSrcLoc) }
+
+trep    :: { (RdrName -> [HsTyVarBndr RdrName] -> DataConDetails (ConDecl RdrName)) }
+        : {- empty -}   { (\ x ts -> Unknown) }
+        | '=' ty        { (\ x ts -> DataCons [ConDecl x x ts [] (VanillaCon [unbangedType $2]) noSrcLoc]) }
+
+tbind	:: { HsTyVarBndr RdrName }
+	:  name                    { IfaceTyVar $1 liftedTypeKind }
+	|  '(' name '::' akind ')' { IfaceTyVar $2 $4 }
+
+tbinds 	:: { [HsTyVarBndr RdrName] }
+	: {- empty -}	{ [] }
+	| tbind tbinds	{ $1:$2 }
+
+vdefgs	:: { [[RdrNameHsDecl]] }
+	: {- empty -}	        { [] }
+	| vdefg ';' vdefgs	{ ($1:$3) }
+
+vdefg	:: { [RdrNameHsDecl] }
+	: '%rec' '{' vdefs1 '}' { $3   }
+	|  vdef                 { [$1] }
+
+vdefs1	:: { [RdrNameHsDecl] }
+	: vdef		        { [$1] }
+	| vdef ';' vdefs1       { $1:$3 }
+
+vdef	:: { RdrNameHsDecl }
+	: qname '::' ty '=' exp { TyClD (CoreDecl  $1 $3 $5 noSrcLoc) }
+
+
+vbind	:: { (RdrName, RdrNameHsType) }
+	: '(' name '::' ty ')'	{ ($2,$4) }
+
+vbinds	:: { [(RdrName, RdrNameHsType)] }
+	: {-empty -} 	{ [] }
+	| vbind vbinds	{ $1:$2 }
+
+bind	:: { UfBinder RdrName }
+        : '@' tbind 	{ let (IfaceTyVar v k) = $2  in UfTyBinder  v k  }
+	| vbind		{ let (v,ty) = $1 in UfValBinder v ty }
+
+binds1 	:: { [UfBinder RdrName] }
+	: bind		{ [$1] }
+	| bind binds1	{ $1:$2 }
+
+attbinds :: { [RdrNameHsTyVar] }
+	: {- empty -} 	     { [] }
+	| '@' tbind attbinds { $2:$3 }
+
+akind	:: { Kind }
+	: '*' 		   { liftedTypeKind   }	
+	| '#'		   { unliftedTypeKind }
+	| '?'		   { openTypeKind     }
+        | '(' kind ')'	   { $2 }
+
+kind 	:: { Kind }
+	: akind 	   { $1 }
+	| akind '->' kind  { mkArrowKind $1 $3 }
+
+cons1	:: { [ConDecl RdrName] }
+	: con		{ [$1] }
+	| con ';' cons1	{ $1:$3 }
+
+con	:: { ConDecl RdrName }
+	: qcname attbinds atys 
+		{ ConDecl $1 $1 $2 [] (VanillaCon (map unbangedType $3)) noSrcLoc}
+
+atys	:: { [ RdrNameHsType] }
+	: {- empty -}   { [] }
+	| aty atys      { $1:$2 }
+
+aty	:: { RdrNameHsType }
+	: name	     { HsTyVar $1 }
+	| qcname     { HsTyVar $1 }
+	| '(' ty ')' { $2 }
+
+
+bty	:: { RdrNameHsType }
+	: aty	     { $1 }
+        | bty aty    { HsAppTy $1 $2 }
+
+ty	:: { RdrNameHsType }
+	: bty	                   { $1 }
+	| bty '->' ty              { HsFunTy $1 $3 }
+	| '%forall' tbinds '.' ty  { HsForAllTy (Just $2) [] $4 }
+
+aexp    :: { UfExpr RdrName }
+	: qname 	{ UfVar $1 }
+        | qcname 	{ UfVar $1 } 
+	| lit		{ UfLit $1 }
+	| '(' exp ')' 	{ $2 }
+
+fexp	:: { UfExpr RdrName }
+	: fexp aexp	{ UfApp $1 $2 }
+	| fexp '@' aty	{ UfApp $1 (UfType $3) }
+	| aexp		{ $1 }
+
+exp	:: { UfExpr RdrName }
+	: fexp		           { $1 }
+	| '\\' binds1 '->' exp 	   { foldr UfLam $4 $2 }
+	| '%let' vdefg '%in' exp   { UfLet (toUfBinder $2) $4 }
+	| '%case' aexp '%of' vbind
+	  '{' alts1 '}'		   { UfCase $2 (fst $4) $6 }
+	| '%coerce' aty exp   	   { UfNote (UfCoerce $2) $3 } -- what about the 'from' type?
+	| '%note' STRING exp 	   
+	    { case $2 of
+	       --"SCC"        -> UfNote (UfSCC "scc") $3
+	       "InlineCall" -> UfNote UfInlineCall $3
+	       "InlineMe"   -> UfNote UfInlineMe $3
+            }
+--        | '%external' STRING aty   { External $2 $3 }
+
+alts1	:: { [UfAlt RdrName] }
+	: alt		{ [$1] }
+	| alt ';' alts1	{ $1:$3 }
+
+alt	:: { UfAlt RdrName }
+	: qcname attbinds vbinds '->' exp 
+		{ {- ToDo: sort out-} (UfDataAlt $1, (map hsTyVarName $2 ++ map fst $3), $5) } 
+	| lit '->' exp
+		{ (UfLitAlt $1, [], $3) }
+	| '%_' '->' exp
+		{ (UfDefault, [], $3) }
+
+lit	:: { Literal }
+	: '(' INTEGER '::' aty ')'	{ MachInt $2 }
+	| '(' RATIONAL '::' aty ')'	{ MachDouble $2 }
+	| '(' CHAR '::' aty ')'		{ MachChar (fromEnum $2) }
+	| '(' STRING '::' aty ')'	{ MachStr (_PK_ $2) }
+
+name	:: { RdrName }
+	: NAME	{ mkUnqual varName (_PK_ $1) }
+
+cname	:: { String }
+	: CNAME	{ $1 }
+         
+mname	:: { String }
+	: CNAME	{ $1 }
+
+modid	:: { ModuleName }
+	: CNAME	{ mkSysModuleNameFS (_PK_ $1) }
+
+qname	:: { RdrName }
+	: name	{ $1 }
+	| mname '.' NAME
+	  { mkIfaceOrig varName (_PK_ $1,_PK_ $3) }
+
+qcname	:: { RdrName }
+        : mname '.' cname 
+		{ mkIfaceOrig dataName (_PK_ $1,_PK_ $3) }
+
+
+{
+
+toUfBinder :: [RdrNameHsDecl] -> UfBinding RdrName
+toUfBinder xs  = 
+ case xs of 
+   [x] -> uncurry UfNonRec (conv x)
+   _   -> UfRec (map conv xs)
+ where
+  conv (TyClD (CoreDecl n ty rhs _)) = (UfValBinder n ty, rhs)
+
+happyError :: P a 
+happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l
+
+}
diff --git a/ghc/compiler/parser/ParserCoreUtils.hs b/ghc/compiler/parser/ParserCoreUtils.hs
new file mode 100644
index 0000000..0d7907a
--- /dev/null
+++ b/ghc/compiler/parser/ParserCoreUtils.hs
@@ -0,0 +1,54 @@
+module ParserCoreUtils where
+
+data ParseResult a = OkP a | FailP String
+type P a = String -> Int -> ParseResult a
+
+thenP :: P a -> (a -> P b) -> P b
+m `thenP`  k = \ s l -> 
+  case m s l of 
+    OkP a -> k a s l
+    FailP s -> FailP s
+
+returnP :: a -> P a
+returnP m _ _ = OkP m
+
+failP :: String -> P a
+failP s s' _ = FailP (s ++ ":" ++ s')
+
+data Token =
+   TKmodule
+ | TKimport
+ | TKdata
+ | TKnewtype
+ | TKforall
+ | TKrec
+ | TKlet
+ | TKin
+ | TKcase
+ | TKof
+ | TKcoerce
+ | TKnote
+ | TKexternal
+ | TKwild
+ | TKoparen
+ | TKcparen
+ | TKobrace
+ | TKcbrace
+ | TKhash
+ | TKeq
+ | TKcoloncolon
+ | TKstar
+ | TKrarrow
+ | TKlambda
+ | TKat
+ | TKdot
+ | TKquestion
+ | TKsemicolon
+ | TKname String
+ | TKcname String
+ | TKinteger Integer
+ | TKrational Rational
+ | TKstring String
+ | TKchar Char
+ | TKEOF
+
diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs
index 057fae3..b009cf1 100644
--- a/ghc/compiler/rename/RnHiFiles.lhs
+++ b/ghc/compiler/rename/RnHiFiles.lhs
@@ -471,6 +471,10 @@ getTyClDeclBinders mod (IfaceSig {tcdName = var, tcdLoc = src_loc})
   = newTopBinder mod var src_loc			`thenRn` \ var_name ->
     returnRn (Avail var_name, [])
 
+getTyClDeclBinders mod (CoreDecl {tcdName = var, tcdLoc = src_loc})
+  = newTopBinder mod var src_loc			`thenRn` \ var_name ->
+    returnRn (Avail var_name, [])
+
 getTyClDeclBinders mod tycl_decl
   = new_top_bndrs mod (tyClDeclNames tycl_decl)		`thenRn` \ names@(main_name:_) ->
     new_top_bndrs mod (tyClDeclSysNames tycl_decl)	`thenRn` \ sys_names ->
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index df20eb0..2759f54 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -156,6 +156,9 @@ tyClDeclFVs (ClassDecl {tcdCtxt = context, tcdTyVars = tyvars, tcdFDs = fds,
 		Just _ -> emptyFVs	-- Source code, so the default methods
 					-- are *bound* not *free*
 
+tyClDeclFVs (CoreDecl {tcdType = ty, tcdRhs = rhs})
+  = extractHsTyNames ty `plusFV` ufExprFVs rhs
+
 ----------------
 hsSigsFVs sigs = plusFVs (map hsSigFVs sigs)
 
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 076e73b..9a07a2f 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -512,6 +512,7 @@ getGates source_fvs decl
 
 get_gates is_used (ForeignType {tcdName = tycon}) = unitNameSet tycon
 get_gates is_used (IfaceSig    {tcdType = ty})    = extractHsTyNames ty
+get_gates is_used (CoreDecl    {tcdType = ty})    = extractHsTyNames ty
 
 get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs})
   = (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets` 
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index cc78801..5b0bf5a 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -286,6 +286,15 @@ rnTyClDecl (IfaceSig {tcdName = name, tcdType = ty, tcdIdInfo = id_infos, tcdLoc
   where
     doc_str = text "In the interface signature for" <+> quotes (ppr name)
 
+rnTyClDecl (CoreDecl {tcdName = name, tcdType = ty, tcdRhs = rhs, tcdLoc = loc})
+  = pushSrcLocRn loc $
+    lookupTopBndrRn name		`thenRn` \ name' ->
+    rnHsType doc_str ty			`thenRn` \ ty' ->
+    rnCoreExpr rhs                      `thenRn` \ rhs' ->
+    returnRn (CoreDecl {tcdName = name', tcdType = ty', tcdRhs = rhs', tcdLoc = loc})
+  where
+    doc_str = text "In the Core declaration for" <+> quotes (ppr name)
+
 rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc})
   = pushSrcLocRn loc 			$
     lookupTopBndrRn name		`thenRn` \ name' ->
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 1d1e53e..597a29d 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -18,7 +18,8 @@ import HsSyn		( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..),
 			  collectMonoBinders, andMonoBinds,
 			  collectSigTysFromMonoBinds
 			)
-import RnHsSyn		( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
+import RnHsSyn		( RenamedHsBinds, RenamedSig, RenamedMonoBinds,
+                          RenamedTyClDecl )
 import TcHsSyn		( TcMonoBinds, TcId, zonkId, mkHsLet )
 
 import TcMonad
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 2d01c49..0e8748f 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -11,7 +11,7 @@ module TcHsSyn (
 	TcMonoBinds, TcHsBinds, TcPat,
 	TcExpr, TcGRHSs, TcGRHS, TcMatch,
 	TcStmt, TcArithSeqInfo, TcRecordBinds,
-	TcHsModule, TcCoreExpr, TcDictBinds,
+	TcHsModule, TcDictBinds,
 	TcForeignExportDecl,
 	
 	TypecheckedHsBinds, TypecheckedRuleDecl,
@@ -21,7 +21,7 @@ module TcHsSyn (
 	TypecheckedMatch, TypecheckedHsModule,
 	TypecheckedGRHSs, TypecheckedGRHS,
 	TypecheckedRecordBinds, TypecheckedDictBinds,
-	TypecheckedMatchContext,
+	TypecheckedMatchContext, TypecheckedCoreBind,
 
 	mkHsTyApp, mkHsDictApp, mkHsConApp,
 	mkHsTyLam, mkHsDictLam, mkHsLet,
@@ -33,7 +33,7 @@ module TcHsSyn (
 	TcId, 
 
 	zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
-	zonkForeignExports, zonkRules
+	zonkForeignExports, zonkRules, zonkCoreExpr, zonkCoreBinds
   ) where
 
 #include "HsVersions.h"
@@ -55,7 +55,7 @@ import TysPrim	  ( charPrimTy, intPrimTy, floatPrimTy,
 		  )
 import TysWiredIn ( charTy, stringTy, intTy, integerTy,
 		    mkListTy, mkPArrTy, mkTupleTy, unitTy )
-import CoreSyn    ( Expr )
+import CoreSyn    ( Expr(..), CoreExpr, CoreBind, Bind(..), CoreAlt, Note(..) )
 import Var	  ( isId )
 import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName )
 import Bag
@@ -88,7 +88,6 @@ type TcArithSeqInfo	= ArithSeqInfo TcId TcPat
 type TcRecordBinds	= HsRecordBinds TcId TcPat
 type TcHsModule	= HsModule TcId TcPat
 
-type TcCoreExpr	= Expr TcId
 type TcForeignExportDecl = ForeignDecl TcId
 type TcRuleDecl 	 = RuleDecl    TcId TcPat
 
@@ -107,6 +106,7 @@ type TypecheckedRecordBinds	= HsRecordBinds Id TypecheckedPat
 type TypecheckedHsModule	= HsModule	Id TypecheckedPat
 type TypecheckedForeignDecl     = ForeignDecl Id
 type TypecheckedRuleDecl	= RuleDecl      Id TypecheckedPat
+type TypecheckedCoreBind        = (Id, CoreExpr)
 \end{code}
 
 \begin{code}
@@ -715,7 +715,7 @@ zonkPat (RecPat n ty tvs dicts rpats)
 	returnNF_Tc ((f, new_pat, pun), ids)
 
 zonkPat (LitPat lit ty)
-  = zonkTcTypeToType ty	    `thenNF_Tc` \ new_ty  ->
+  = zonkTcTypeToType ty	        `thenNF_Tc` \ new_ty  ->
     returnNF_Tc (LitPat lit new_ty, emptyBag)
 
 zonkPat (SigPat pat ty expr)
@@ -730,15 +730,15 @@ zonkPat (NPat lit ty expr)
     returnNF_Tc (NPat lit new_ty new_expr, emptyBag)
 
 zonkPat (NPlusKPat n k ty e1 e2)
-  = zonkIdBndr n		`thenNF_Tc` \ new_n ->
-    zonkTcTypeToType ty	`thenNF_Tc` \ new_ty ->
-    zonkExpr e1		`thenNF_Tc` \ new_e1 ->
-    zonkExpr e2		`thenNF_Tc` \ new_e2 ->
+  = zonkIdBndr n	        `thenNF_Tc` \ new_n ->
+    zonkTcTypeToType ty	        `thenNF_Tc` \ new_ty ->
+    zonkExpr e1		        `thenNF_Tc` \ new_e1 ->
+    zonkExpr e2		        `thenNF_Tc` \ new_e2 ->
     returnNF_Tc (NPlusKPat new_n k new_ty new_e1 new_e2, unitBag new_n)
 
 zonkPat (DictPat ds ms)
-  = mapNF_Tc zonkIdBndr ds    `thenNF_Tc` \ new_ds ->
-    mapNF_Tc zonkIdBndr ms    `thenNF_Tc` \ new_ms ->
+  = mapNF_Tc zonkIdBndr ds      `thenNF_Tc` \ new_ds ->
+    mapNF_Tc zonkIdBndr ms      `thenNF_Tc` \ new_ms ->
     returnNF_Tc (DictPat new_ds new_ms,
 		 listToBag new_ds `unionBags` listToBag new_ms)
 
@@ -791,3 +791,77 @@ zonkRule (IfaceRuleOut fun rule)
   = zonkIdOcc fun	`thenNF_Tc` \ fun' ->
     returnNF_Tc (IfaceRuleOut fun' rule)
 \end{code}
+
+\begin{code}
+zonkCoreBinds :: [(Id, Type, CoreExpr)] -> NF_TcM [(Id, CoreExpr)]
+zonkCoreBinds ls = mapNF_Tc zonkOne ls
+ where
+  zonkOne (i, t, e) = 
+    zonkIdOcc          i `thenNF_Tc` \ i' ->
+    zonkCoreExpr       e `thenNF_Tc` \ e' ->
+    returnNF_Tc (i',e')
+
+-- needed?
+zonkCoreExpr :: CoreExpr -> NF_TcM CoreExpr
+zonkCoreExpr e = 
+  case e of
+    Var i ->
+      zonkIdOcc i `thenNF_Tc` \ i' ->
+      returnNF_Tc (Var i')
+    Lit l -> returnNF_Tc (Lit l)
+    App f arg ->
+      zonkCoreExpr f   `thenNF_Tc` \ f' ->
+      zonkCoreExpr arg `thenNF_Tc` \ arg' ->
+      returnNF_Tc (App f' arg')
+    Lam b e ->
+      zonkIdOcc b      `thenNF_Tc` \ b' ->
+      zonkCoreExpr e   `thenNF_Tc` \ e' ->
+      returnNF_Tc (Lam b' e')
+    Case scrut n alts ->
+      zonkCoreExpr scrut        `thenNF_Tc` \ scrut' ->
+      zonkIdOcc n               `thenNF_Tc` \ n' ->
+      mapNF_Tc zonkCoreAlt alts `thenNF_Tc` \ alts' -> 
+      returnNF_Tc (Case scrut' n' alts')
+    Let b rhs ->
+      zonkCoreBind b            `thenNF_Tc` \ b' ->
+      zonkCoreExpr rhs          `thenNF_Tc` \ rhs' ->
+      returnNF_Tc (Let b' rhs')
+    Note note e ->
+      zonkNote note             `thenNF_Tc` \ note' ->
+      zonkCoreExpr e            `thenNF_Tc` \ e' ->
+      returnNF_Tc (Note note' e')
+    Type t -> 
+      zonkTcTypeToType t         `thenNF_Tc` \ t' ->
+      returnNF_Tc (Type t')
+
+zonkCoreBind :: CoreBind -> NF_TcM CoreBind
+zonkCoreBind (NonRec b e) = 
+   zonkIdOcc    b `thenNF_Tc`  \ b' ->
+   zonkCoreExpr e `thenNF_Tc`  \ e' ->
+   returnNF_Tc (NonRec b' e')
+zonkCoreBind (Rec bs) = 
+   mapNF_Tc zonkIt bs `thenNF_Tc` \ bs' ->
+   returnNF_Tc (Rec bs')
+ where
+  zonkIt (b,e) = 
+   zonkIdOcc    b `thenNF_Tc`  \ b' ->
+   zonkCoreExpr e `thenNF_Tc`  \ e' ->
+   returnNF_Tc (b',e')
+
+
+zonkCoreAlt :: CoreAlt -> NF_TcM CoreAlt
+zonkCoreAlt (ac, bs, rhs) = 
+  mapNF_Tc zonkIdOcc bs `thenNF_Tc` \ bs'  ->
+  zonkCoreExpr rhs      `thenNF_Tc` \ rhs' ->
+  returnNF_Tc (ac, bs', rhs')
+
+zonkNote :: Note -> NF_TcM Note
+zonkNote n = 
+ case n of
+   Coerce t f ->
+     zonkTcTypeToType t `thenNF_Tc` \ t' ->
+     zonkTcTypeToType f `thenNF_Tc` \ f' ->
+     returnNF_Tc (Coerce t' f')
+   _ -> returnNF_Tc n
+
+\end{code}
diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index da180d8..efaac5c 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -4,7 +4,12 @@
 \section[TcIfaceSig]{Type checking of type signatures in interface files}
 
 \begin{code}
-module TcIfaceSig ( tcInterfaceSigs, tcDelay, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
+module TcIfaceSig ( tcInterfaceSigs,
+                    tcDelay,
+		    tcVar,
+		    tcCoreExpr,
+		    tcCoreLamBndrs,
+		    tcCoreBinds ) where
 
 #include "HsVersions.h"
 
@@ -31,7 +36,7 @@ import MkId		( mkFCallId )
 import IdInfo
 import TyCon		( tyConDataCons )
 import DataCon		( DataCon, dataConId, dataConSig, dataConArgTys )
-import Type		( mkTyVarTys, splitTyConApp )
+import Type		( Type, mkTyVarTys, splitTyConApp )
 import TysWiredIn	( tupleCon )
 import Var		( mkTyVar, tyVarKind )
 import Name		( Name, nameIsLocalOrFrom )
@@ -366,6 +371,28 @@ tcConAlt (UfDataAlt con_name)
 		    Nothing  -> pprPanic "tcCoreAlt" (ppr con_id))
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Core decls}
+%*									*
+%************************************************************************
+
+
+\begin{code}
+tcCoreBinds :: [RenamedTyClDecl]
+            -> TcM [(Id, Type, CoreExpr)]
+tcCoreBinds ls = mapTc tcOne ls
+ where
+  tcOne (CoreDecl { tcdName = nm, tcdType = ty, tcdRhs = rhs }) =
+   tcVar nm         `thenTc` \ i ->
+   tcIfaceType ty   `thenTc` \ ty' ->
+   tcCoreExpr  rhs  `thenTc` \ rhs' ->
+   returnTc (i,ty',rhs')
+
+\end{code}
+
+
+
 \begin{code}
 ifaceSigCtxt sig_name
   = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]
diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 3cbd0a6..f5c5c44 100644
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -15,7 +15,7 @@ module TcModule (
 import CmdLineOpts	( DynFlag(..), DynFlags, dopt )
 import HsSyn		( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
 			  Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
-			  isSourceInstDecl, mkSimpleMatch, placeHolderType
+			  isSourceInstDecl, mkSimpleMatch, placeHolderType, isCoreDecl
 			)
 import PrelNames	( ioTyConName, printName,
 			  returnIOName, bindIOName, failIOName, runMainName, 
@@ -26,8 +26,9 @@ import RnHsSyn		( RenamedHsDecl, RenamedStmt, RenamedHsExpr,
 			  RenamedRuleDecl, RenamedTyClDecl, RenamedInstDecl )
 import TcHsSyn		( TypecheckedMonoBinds, TypecheckedHsExpr,
 			  TypecheckedForeignDecl, TypecheckedRuleDecl,
+			  TypecheckedCoreBind,
 			  zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
-			  zonkExpr, zonkIdBndr
+			  zonkExpr, zonkIdBndr, zonkCoreBinds
 			)
 
 import Rename		( RnResult(..) )
@@ -53,7 +54,7 @@ import TcEnv		( TcEnv, RecTcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv,
 			)
 import TcRules		( tcIfaceRules, tcSourceRules )
 import TcForeign	( tcForeignImports, tcForeignExports )
-import TcIfaceSig	( tcInterfaceSigs )
+import TcIfaceSig	( tcInterfaceSigs, tcCoreBinds )
 import TcInstDcls	( tcInstDecls1, tcIfaceInstDecls1, addInstDFuns, initInstEnv, tcInstDecls2 )
 import TcSimplify	( tcSimplifyTop, tcSimplifyInfer )
 import TcTyClsDecls	( tcTyAndClassDecls )
@@ -352,6 +353,7 @@ data TcResults
 	tc_insts   :: [DFunId],			-- Instances 
 	tc_rules   :: [TypecheckedRuleDecl],	-- Transformation rules
 	tc_binds   :: TypecheckedMonoBinds,	-- Bindings
+	tc_cbinds  :: [TypecheckedCoreBind],    -- (external)Core value decls/bindings.
 	tc_fords   :: [TypecheckedForeignDecl]	-- Foreign import & exports.
     }
 
@@ -403,6 +405,7 @@ tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod,
         traceTc (text "Tc5")				`thenNF_Tc_`
 	tcTopBinds (val_binds `ThenBinds` deriv_binds)	`thenTc` \ ((val_binds, env2), lie_valdecls) ->
 	
+        tcCoreBinds core_binds                          `thenTc` \ core_binds' -> 
      	-- Second pass over class and instance declarations, 
 	-- plus rules and foreign exports, to generate bindings
 	tcSetEnv env2				$
@@ -458,6 +461,7 @@ tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod,
 	in
  	traceTc (text "Tc7")		`thenNF_Tc_`
 	zonkTopBinds all_binds		`thenNF_Tc` \ (all_binds', final_env)  ->
+	zonkCoreBinds core_binds'       `thenNF_Tc` \ core_binds' ->
 	tcSetEnv final_env		$
 		-- zonkTopBinds puts all the top-level Ids into the tcGEnv
  	traceTc (text "Tc8")		`thenNF_Tc_`
@@ -476,6 +480,7 @@ tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod,
 			      tc_insts   = map iDFunId inst_info,
 			      tc_binds   = all_binds', 
 			      tc_fords   = foi_decls ++ foe_decls',
+			      tc_cbinds  = core_binds',
 			      tc_rules   = src_rules'
 			    }
 	)
@@ -486,6 +491,8 @@ tcModule pcs hst (RnResult { rr_decls = decls, rr_mod = this_mod,
     rule_decls = [d | RuleD d <- decls]
     inst_decls = [d | InstD d <- decls]
     val_decls  = [d | ValD d  <- decls]
+    
+    core_binds = [d | d <- tycl_decls, isCoreDecl d]
 
     (src_inst_decls, iface_inst_decls) = partition isSourceInstDecl  	       inst_decls
     (src_rule_decls, iface_rule_decls) = partition (isSourceRuleDecl this_mod) rule_decls