Commit 76293b14 authored by sof's avatar sof
Browse files

[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.)
parent 57f83897
......@@ -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))
......
......@@ -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
......
......@@ -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]
......
......@@ -332,6 +332,7 @@ data HscLang
| HscAsm
| HscJava
| HscILX
| HscCore
| HscInterpreted
| HscNothing
deriving (Eq, Show)
......
{-# 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) )
......
-----------------------------------------------------------------------------
-- $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" ])
......
......@@ -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)))
......
-----------------------------------------------------------------------------
-- $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)
......
......@@ -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,
......
{-# 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
......
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)
{
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
}