Commit dc00fb1b authored by Austin Seipp's avatar Austin Seipp

compiler: de-lhs prelude/

Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent 1389ff56
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
\section[Foreign]{Foreign calls}
-}
\begin{code}
{-# LANGUAGE DeriveDataTypeable #-}
module ForeignCall (
......@@ -25,16 +25,15 @@ import Module
import Data.Char
import Data.Data
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection{Data types}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
newtype ForeignCall = CCall CCallSpec
deriving Eq
{-! derive: Binary !-}
......@@ -46,10 +45,7 @@ isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe
-- but this simple printer will do for now
instance Outputable ForeignCall where
ppr (CCall cc) = ppr cc
\end{code}
\begin{code}
data Safety
= PlaySafe -- Might invoke Haskell GC, or do a call back, or
-- switch threads, etc. So make sure things are
......@@ -82,16 +78,15 @@ playSafe PlayRisky = False
playInterruptible :: Safety -> Bool
playInterruptible PlayInterruptible = True
playInterruptible _ = False
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection{Calling C}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
data CExportSpec
= CExportStatic -- foreign export ccall foo :: ty
CLabelString -- C Name of exported function
......@@ -105,11 +100,8 @@ data CCallSpec
Safety
deriving( Eq )
{-! derive: Binary !-}
\end{code}
The call target:
\begin{code}
-- The call target:
-- | How to call a particular function in C-land.
data CCallTarget
......@@ -138,9 +130,8 @@ data CCallTarget
isDynamicTarget :: CCallTarget -> Bool
isDynamicTarget DynamicTarget = True
isDynamicTarget _ = False
\end{code}
{-
Stuff to do with calling convention:
ccall: Caller allocates parameters, *and* deallocates them.
......@@ -154,8 +145,8 @@ so perhaps we should emit a warning if it's being used on other
platforms.
See: http://www.programmersheaven.com/2/Calling-conventions
-}
\begin{code}
-- any changes here should be replicated in the CallConv type in template haskell
data CCallConv = CCallConv | CApiConv | StdCallConv | PrimCallConv | JavaScriptCallConv
deriving (Eq, Data, Typeable)
......@@ -177,21 +168,19 @@ ccallConvToInt CCallConv = 1
ccallConvToInt CApiConv = panic "ccallConvToInt CApiConv"
ccallConvToInt (PrimCallConv {}) = panic "ccallConvToInt PrimCallConv"
ccallConvToInt JavaScriptCallConv = panic "ccallConvToInt JavaScriptCallConv"
\end{code}
{-
Generate the gcc attribute corresponding to the given
calling convention (used by PprAbsC):
-}
\begin{code}
ccallConvAttribute :: CCallConv -> SDoc
ccallConvAttribute StdCallConv = text "__attribute__((__stdcall__))"
ccallConvAttribute CCallConv = empty
ccallConvAttribute CApiConv = empty
ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"
ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv"
\end{code}
\begin{code}
type CLabelString = FastString -- A C label, completely unencoded
pprCLabelString :: CLabelString -> SDoc
......@@ -204,12 +193,9 @@ isCLabelString lbl
ok c = isAlphaNum c || c == '_' || c == '.'
-- The '.' appears in e.g. "foo.so" in the
-- module part of a ExtName. Maybe it should be separate
\end{code}
-- Printing into C files:
Printing into C files:
\begin{code}
instance Outputable CExportSpec where
ppr (CExportStatic str _) = pprCLabelString str
......@@ -233,9 +219,7 @@ instance Outputable CCallSpec where
ppr_fun DynamicTarget
= text "__dyn_ccall" <> gc_suf <+> text "\"\""
\end{code}
\begin{code}
-- The filename for a C header file
newtype Header = Header FastString
deriving (Eq, Data, Typeable)
......@@ -253,16 +237,15 @@ instance Outputable CType where
where hDoc = case mh of
Nothing -> empty
Just h -> ppr h
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection{Misc}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
{-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
instance Binary ForeignCall where
put_ bh (CCall aa) = put_ bh aa
......@@ -350,4 +333,3 @@ instance Binary Header where
put_ bh (Header h) = put_ bh h
get bh = do h <- get bh
return (Header h)
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
\section[PrelInfo]{The @PrelInfo@ interface to the compiler's prelude knowledge}
-}
\begin{code}
{-# LANGUAGE CPP #-}
module PrelInfo (
wiredInIds, ghcPrimIds,
......@@ -39,13 +39,13 @@ import Util
import {-# SOURCE #-} TcTypeNats ( typeNatTyCons )
import Data.Array
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection[builtinNameInfo]{Lookup built-in names}
%* *
%************************************************************************
* *
************************************************************************
Notes about wired in things
~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -64,9 +64,8 @@ Notes about wired in things
* MkIface prunes out wired-in things before putting them in an interface file.
So interface files never contain wired-in things.
-}
\begin{code}
wiredInThings :: [TyThing]
-- This list is used only to initialise HscMain.knownKeyNames
-- to ensure that when you say "Prelude.map" in your source code, you
......@@ -86,19 +85,19 @@ wiredInThings
where
tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons
++ typeNatTyCons)
\end{code}
{-
We let a lot of "non-standard" values be visible, so that we can make
sense of them in interface pragmas. It's cool, though they all have
"non-standard" names, so they won't get past the parser in user code.
%************************************************************************
%* *
************************************************************************
* *
PrimOpIds
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
primOpIds :: Array Int Id
-- A cache of the PrimOp Ids, indexed by PrimOp tag
primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op)
......@@ -106,51 +105,47 @@ primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op)
primOpId :: PrimOp -> Id
primOpId op = primOpIds ! primOpTag op
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{Export lists for pseudo-modules (GHC.Prim)}
%* *
%************************************************************************
* *
************************************************************************
GHC.Prim "exports" all the primops and primitive types, some
wired-in Ids.
-}
\begin{code}
ghcPrimExports :: [IfaceExport]
ghcPrimExports
= map (Avail . idName) ghcPrimIds ++
map (Avail . idName . primOpId) allThePrimOps ++
[ AvailTC n [n]
| tc <- funTyCon : primTyCons, let n = tyConName tc ]
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{Built-in keys}
%* *
%************************************************************************
* *
************************************************************************
ToDo: make it do the ``like'' part properly (as in 0.26 and before).
-}
\begin{code}
maybeCharLikeCon, maybeIntLikeCon :: DataCon -> Bool
maybeCharLikeCon con = con `hasKey` charDataConKey
maybeIntLikeCon con = con `hasKey` intDataConKey
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{Class predicates}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
isNumericClass, isStandardClass :: Class -> Bool
isNumericClass clas = classKey clas `is_elem` numericClassKeys
......@@ -158,4 +153,3 @@ isStandardClass clas = classKey clas `is_elem` standardClassKeys
is_elem :: Eq a => a -> [a] -> Bool
is_elem = isIn "is_X_Class"
\end{code}
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
{-
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
\section[PrelNames]{Definitions of prelude modules and names}
......@@ -100,8 +100,8 @@ This is accomplished through a combination of mechanisms:
than trying to find it in the original-name cache.
See also Note [Built-in syntax and the OrigNameCache]
-}
\begin{code}
{-# LANGUAGE CPP #-}
module PrelNames (
......@@ -127,36 +127,32 @@ import SrcLoc
import FastString
import Config ( cIntegerLibraryType, IntegerLibrary(..) )
import Panic ( panic )
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
allNameStrings
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
allNameStrings :: [String]
-- Infinite list of a,b,c...z, aa, ab, ac, ... etc
allNameStrings = [ c:cs | cs <- "" : allNameStrings, c <- ['a'..'z'] ]
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{Local Names}
%* *
%************************************************************************
* *
************************************************************************
This *local* name is used by the interactive stuff
-}
\begin{code}
itName :: Unique -> SrcSpan -> Name
itName uniq loc = mkInternalName uniq (mkOccNameFS varName (fsLit "it")) loc
\end{code}
\begin{code}
-- mkUnboundName makes a place-holder Name; it shouldn't be looked at except possibly
-- during compiler debugging.
mkUnboundName :: RdrName -> Name
......@@ -164,14 +160,13 @@ mkUnboundName rdr_name = mkInternalName unboundKey (rdrNameOcc rdr_name) noSrcSp
isUnboundName :: Name -> Bool
isUnboundName name = name `hasKey` unboundKey
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{Known key Names}
%* *
%************************************************************************
* *
************************************************************************
This section tells what the compiler knows about the association of
names with uniques. These ones are the *non* wired-in ones. The
......@@ -182,8 +177,8 @@ The names for DPH can come from one of multiple backend packages. At the point w
the names for multiple backends. That works out fine, although they use the same uniques,
as we are guaranteed to only load one backend; hence, only one of the different names
sharing a unique will be used.
-}
\begin{code}
basicKnownKeyNames :: [Name]
basicKnownKeyNames
= genericTyConNames
......@@ -368,18 +363,18 @@ genericTyConNames = [
d1TyConName, c1TyConName, s1TyConName, noSelTyConName,
repTyConName, rep1TyConName
]
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{Module names}
%* *
%************************************************************************
* *
************************************************************************
--MetaHaskell Extension Add a new module here
\begin{code}
-}
pRELUDE :: Module
pRELUDE = mkBaseModule_ pRELUDE_NAME
......@@ -491,29 +486,28 @@ mkMainModule m = mkModule mainPackageKey (mkModuleNameFS m)
mkMainModule_ :: ModuleName -> Module
mkMainModule_ m = mkModule mainPackageKey m
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{Constructing the names of tuples
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
mkTupleModule :: TupleSort -> Module
mkTupleModule BoxedTuple = gHC_TUPLE
mkTupleModule ConstraintTuple = gHC_TUPLE
mkTupleModule UnboxedTuple = gHC_PRIM
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
RdrNames
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
main_RDR_Unqual :: RdrName
main_RDR_Unqual = mkUnqual varName (fsLit "main")
-- We definitely don't want an Orig RdrName, because
......@@ -738,13 +732,13 @@ varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str)
tcQual_RDR mod str = mkOrig mod (mkOccNameFS tcName str)
clsQual_RDR mod str = mkOrig mod (mkOccNameFS clsName str)
dataQual_RDR mod str = mkOrig mod (mkOccNameFS dataName str)
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{Known-key names}
%* *
%************************************************************************
* *
************************************************************************
Many of these Names are not really "built in", but some parts of the
compiler (notably the deriving mechanism) need to mention their names,
......@@ -752,9 +746,8 @@ and it's convenient to write them all down in one place.
--MetaHaskell Extension add the constrs and the lower case case
-- guys as well (perhaps) e.g. see trueDataConName below
-}
\begin{code}
wildCardName :: Name
wildCardName = mkSystemVarName wildCardKey (fsLit "wild")
......@@ -1165,17 +1158,17 @@ pLUGINS :: Module
pLUGINS = mkThisGhcModule (fsLit "Plugins")
pluginTyConName :: Name
pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{Local helpers}
%* *
%************************************************************************
* *
************************************************************************
All these are original names; hence mkOrig
-}
\begin{code}
varQual, tcQual, clsQual :: Module -> FastString -> Unique -> Name
varQual = mk_known_key_name varName
tcQual = mk_known_key_name tcName
......@@ -1188,16 +1181,16 @@ mk_known_key_name space modu str unique
conName :: Module -> FastString -> Unique -> Name
conName modu occ unique
= mkExternalName unique modu (mkOccNameFS dataName occ) noSrcSpan
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection[Uniques-prelude-Classes]{@Uniques@ for wired-in @Classes@}
%* *
%************************************************************************
* *
************************************************************************
--MetaHaskell extension hand allocate keys here
-}
\begin{code}
boundedClassKey, enumClassKey, eqClassKey, floatingClassKey,
fractionalClassKey, integralClassKey, monadClassKey, dataClassKey,
functorClassKey, numClassKey, ordClassKey, readClassKey, realClassKey,
......@@ -1270,15 +1263,15 @@ ghciIoClassKey = mkPreludeClassUnique 44
ipClassNameKey :: Unique
ipClassNameKey = mkPreludeClassUnique 45
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection[Uniques-prelude-TyCons]{@Uniques@ for wired-in @TyCons@}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
addrPrimTyConKey, arrayPrimTyConKey, arrayArrayPrimTyConKey, boolTyConKey, byteArrayPrimTyConKey,
charPrimTyConKey, charTyConKey, doublePrimTyConKey, doubleTyConKey,
floatPrimTyConKey, floatTyConKey, funTyConKey, intPrimTyConKey,
......@@ -1495,15 +1488,15 @@ smallMutableArrayPrimTyConKey = mkPreludeTyConUnique 179
unitTyConKey :: Unique
unitTyConKey = mkTupleTyConUnique BoxedTuple 0
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection[Uniques-prelude-DataCons]{@Uniques@ for wired-in @DataCons@}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
charDataConKey, consDataConKey, doubleDataConKey, falseDataConKey,
floatDataConKey, intDataConKey, integerSDataConKey, nilDataConKey,
ratioDataConKey, stableNameDataConKey, trueDataConKey, wordDataConKey,
......@@ -1545,15 +1538,15 @@ eqDataConKey = mkPreludeDataConUnique 28
gtDataConKey = mkPreludeDataConUnique 29
coercibleDataConKey = mkPreludeDataConUnique 32
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsubsection[Uniques-prelude-Ids]{@Uniques@ for wired-in @Ids@ (except @DataCons@)}
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
wildCardKey, absentErrorIdKey, augmentIdKey, appendIdKey,
buildIdKey, errorIdKey, foldrIdKey, recSelErrorIdKey,
seqIdKey, irrefutPatErrorIdKey, eqStringIdKey,
......@@ -1716,13 +1709,13 @@ magicDictKey = mkPreludeMiscIdUnique 156
coerceKey :: Unique
coerceKey = mkPreludeMiscIdUnique 157
\end{code}
{-
Certain class operations from Prelude classes. They get their own
uniques so we can look them up easily when we want to conjure them up
during type checking.
-}
\begin{code}
-- Just a place holder for unbound variables produced by the renamer:
unboundKey :: Unique
unboundKey = mkPreludeMiscIdUnique 160
......@@ -1800,19 +1793,19 @@ proxyHashKey = mkPreludeMiscIdUnique 502
---------------- Template Haskell -------------------
-- USES IdUniques 200-499
-----------------------------------------------------
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection[Class-std-groups]{Standard groups of Prelude classes}
%* *
%************************************************************************
* *
************************************************************************
NOTE: @Eq@ and @Text@ do need to appear in @standardClasses@
even though every numeric class has these two as a superclass,
because the list of ambiguous dictionaries hasn't been simplified.
-}
\begin{code}
numericClassKeys :: [Unique]
numericClassKeys =
[ numClassKey
......@@ -1840,14 +1833,13 @@ standardClassKeys = derivableClassKeys ++ numericClassKeys
applicativeClassKey, foldableClassKey,
traversableClassKey, alternativeClassKey