Commit 6c381e87 authored by partain's avatar partain

[project @ 1996-03-19 08:58:34 by partain]

simonpj/sansom/partain/dnt 1.3 compiler stuff through 96/03/18
parent 8147a9f0
...@@ -53,8 +53,10 @@ you will screw up the layout where they are used in case expressions! ...@@ -53,8 +53,10 @@ you will screw up the layout where they are used in case expressions!
#ifdef DEBUG #ifdef DEBUG
#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else #define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
#define CHK_Ubiq() import Ubiq
#else #else
#define ASSERT(e) #define ASSERT(e)
#define CHK_Ubiq()
#endif #endif
-- ToDo: ghci needs to load far too many bits of the backend because -- ToDo: ghci needs to load far too many bits of the backend because
......
This diff is collapsed.
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface AbsCFuns where
import AbsCSyn(AbstractC, CAddrMode, CExprMacro, CStmtMacro, MagicId, RegRelative, ReturnInfo)
import BasicLit(BasicLit)
import CLabelInfo(CLabel)
import ClosureInfo(ClosureInfo)
import CostCentre(CostCentre)
import HeapOffs(HeapOffset)
import Maybes(Labda)
import PreludePS(_PackedString)
import PrimKind(PrimKind)
import PrimOps(PrimOp)
import SplitUniq(SplitUniqSupply)
import Unique(Unique)
data AbstractC
data CAddrMode
data PrimKind
data SplitUniqSupply
amodeCanSurviveGC :: CAddrMode -> Bool
flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC
getAmodeKind :: CAddrMode -> PrimKind
kindFromMagicId :: MagicId -> PrimKind
mixedPtrLocn :: CAddrMode -> Bool
mixedTypeLocn :: CAddrMode -> Bool
mkAbsCStmtList :: AbstractC -> [AbstractC]
mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
mkAbstractCs :: [AbstractC] -> AbstractC
mkAlgAltsCSwitch :: CAddrMode -> [(Int, AbstractC)] -> AbstractC -> AbstractC
nonemptyAbsC :: AbstractC -> Labda AbstractC
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface AbsCSyn where
import AbsCFuns(amodeCanSurviveGC, flattenAbsC, getAmodeKind, kindFromMagicId, mixedPtrLocn, mixedTypeLocn, mkAbsCStmtList, mkAbsCStmts, mkAbstractCs, mkAlgAltsCSwitch, nonemptyAbsC)
import BasicLit(BasicLit(..), mkMachInt, mkMachWord)
import CLabelInfo(CLabel)
import CharSeq(CSeq)
import ClosureInfo(ClosureInfo, LambdaFormInfo)
import CmdLineOpts(GlobalSwitch, SimplifierSwitch)
import CostCentre(CostCentre)
import HeapOffs(HeapOffset, HpRelOffset(..), SpARelOffset(..), SpBRelOffset(..), VirtualHeapOffset(..), VirtualSpAOffset(..), VirtualSpBOffset(..), addOff, fixedHdrSize, intOff, intOffsetIntoGoods, isZeroOff, maxOff, possiblyEqualHeapOffset, pprHeapOffset, subOff, totHdrSize, varHdrSize, zeroOff)
import Id(ConTag(..), Id)
import Maybes(Labda)
import Outputable(ExportFlag, NamedThing(..), Outputable(..))
import PprAbsC(dumpRealC, writeRealC)
import PreludePS(_PackedString)
import PreludeRatio(Ratio(..))
import Pretty(PprStyle, Pretty(..), PrettyRep)
import PrimKind(PrimKind(..))
import PrimOps(PrimOp)
import SMRep(SMRep)
import SplitUniq(SplitUniqSupply)
import SrcLoc(SrcLoc)
import Stdio(_FILE)
import StgSyn(StgAtom, StgExpr, UpdateFlag)
import TyCon(TyCon)
import UniType(UniType)
import UniqFM(UniqFM)
import UniqSet(UniqSet(..))
import Unique(Unique)
import Unpretty(Unpretty(..))
class NamedThing a where
getExportFlag :: a -> ExportFlag
isLocallyDefined :: a -> Bool
getOrigName :: a -> (_PackedString, _PackedString)
getOccurrenceName :: a -> _PackedString
getInformingModules :: a -> [_PackedString]
getSrcLoc :: a -> SrcLoc
getTheUnique :: a -> Unique
hasType :: a -> Bool
getType :: a -> UniType
fromPreludeCore :: a -> Bool
class Outputable a where
ppr :: PprStyle -> a -> Int -> Bool -> PrettyRep
data AbstractC = AbsCNop | AbsCStmts AbstractC AbstractC | CAssign CAddrMode CAddrMode | CJump CAddrMode | CFallThrough CAddrMode | CReturn CAddrMode ReturnInfo | CSwitch CAddrMode [(BasicLit, AbstractC)] AbstractC | CCodeBlock CLabel AbstractC | CInitHdr ClosureInfo RegRelative CAddrMode Bool | COpStmt [CAddrMode] PrimOp [CAddrMode] Int [MagicId] | CSimultaneous AbstractC | CMacroStmt CStmtMacro [CAddrMode] | CCallProfCtrMacro _PackedString [CAddrMode] | CCallProfCCMacro _PackedString [CAddrMode] | CStaticClosure CLabel ClosureInfo CAddrMode [CAddrMode] | CClosureInfoAndCode ClosureInfo AbstractC (Labda AbstractC) CAddrMode [Char] Int | CRetVector CLabel [Labda CAddrMode] AbstractC | CRetUnVector CLabel CAddrMode | CFlatRetVector CLabel [CAddrMode] | CCostCentreDecl Bool CostCentre | CClosureUpdInfo AbstractC | CSplitMarker
data BasicLit = MachChar Char | MachStr _PackedString | MachAddr Integer | MachInt Integer Bool | MachFloat (Ratio Integer) | MachDouble (Ratio Integer) | MachLitLit _PackedString PrimKind | NoRepStr _PackedString | NoRepInteger Integer | NoRepRational (Ratio Integer)
data CAddrMode = CVal RegRelative PrimKind | CAddr RegRelative | CReg MagicId | CTableEntry CAddrMode CAddrMode PrimKind | CTemp Unique PrimKind | CLbl CLabel PrimKind | CUnVecLbl CLabel CLabel | CCharLike CAddrMode | CIntLike CAddrMode | CString _PackedString | CLit BasicLit | CLitLit _PackedString PrimKind | COffset HeapOffset | CCode AbstractC | CLabelledCode CLabel AbstractC | CJoinPoint Int Int | CMacroExpr PrimKind CExprMacro [CAddrMode] | CCostCentre CostCentre Bool
data CExprMacro = INFO_PTR | ENTRY_CODE | INFO_TAG | EVAL_TAG
data CLabel
data CSeq
data CStmtMacro = ARGS_CHK_A_LOAD_NODE | ARGS_CHK_A | ARGS_CHK_B_LOAD_NODE | ARGS_CHK_B | HEAP_CHK | STK_CHK | UPD_CAF | UPD_IND | UPD_INPLACE_NOPTRS | UPD_INPLACE_PTRS | UPD_BH_UPDATABLE | UPD_BH_SINGLE_ENTRY | PUSH_STD_UPD_FRAME | POP_STD_UPD_FRAME | SET_ARITY | CHK_ARITY | SET_TAG
data ClosureInfo
data LambdaFormInfo
data GlobalSwitch
data SimplifierSwitch
data CostCentre
data HeapOffset
type HpRelOffset = HeapOffset
data MagicId = BaseReg | StkOReg | VanillaReg PrimKind Int# | FloatReg Int# | DoubleReg Int# | TagReg | RetReg | SpA | SuA | SpB | SuB | Hp | HpLim | LivenessReg | ActivityReg | StdUpdRetVecReg | StkStubReg | CurCostCentre | VoidReg
data RegRelative = HpRel HeapOffset HeapOffset | SpARel Int Int | SpBRel Int Int | NodeRel HeapOffset
data ReturnInfo = DirectReturn | StaticVectoredReturn Int | DynamicVectoredReturn CAddrMode
type SpARelOffset = Int
type SpBRelOffset = Int
type VirtualHeapOffset = HeapOffset
type VirtualSpAOffset = Int
type VirtualSpBOffset = Int
type ConTag = Int
data Id
data Labda a
data ExportFlag
data PprStyle
type Pretty = Int -> Bool -> PrettyRep
data PrettyRep
data PrimKind = PtrKind | CodePtrKind | DataPtrKind | RetKind | InfoPtrKind | CostCentreKind | CharKind | IntKind | WordKind | AddrKind | FloatKind | DoubleKind | MallocPtrKind | StablePtrKind | ArrayKind | ByteArrayKind | VoidKind
data PrimOp
data SMRep
data SplitUniqSupply
data SrcLoc
data StgAtom a
data StgExpr a b
data UpdateFlag
data TyCon
data UniType
data UniqFM a
type UniqSet a = UniqFM a
data Unique
type Unpretty = CSeq
amodeCanSurviveGC :: CAddrMode -> Bool
flattenAbsC :: SplitUniqSupply -> AbstractC -> AbstractC
getAmodeKind :: CAddrMode -> PrimKind
kindFromMagicId :: MagicId -> PrimKind
mixedPtrLocn :: CAddrMode -> Bool
mixedTypeLocn :: CAddrMode -> Bool
mkAbsCStmtList :: AbstractC -> [AbstractC]
mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
mkAbstractCs :: [AbstractC] -> AbstractC
mkAlgAltsCSwitch :: CAddrMode -> [(Int, AbstractC)] -> AbstractC -> AbstractC
nonemptyAbsC :: AbstractC -> Labda AbstractC
mkMachInt :: Integer -> BasicLit
mkMachWord :: Integer -> BasicLit
addOff :: HeapOffset -> HeapOffset -> HeapOffset
fixedHdrSize :: HeapOffset
dumpRealC :: (GlobalSwitch -> Bool) -> AbstractC -> [Char]
infoptr :: MagicId
intOff :: Int -> HeapOffset
intOffsetIntoGoods :: HeapOffset -> Labda Int
isVolatileReg :: MagicId -> Bool
isZeroOff :: HeapOffset -> Bool
maxOff :: HeapOffset -> HeapOffset -> HeapOffset
mkCCostCentre :: CostCentre -> CAddrMode
mkIntCLit :: Int -> CAddrMode
node :: MagicId
possiblyEqualHeapOffset :: HeapOffset -> HeapOffset -> Bool
pprHeapOffset :: PprStyle -> HeapOffset -> CSeq
subOff :: HeapOffset -> HeapOffset -> HeapOffset
totHdrSize :: SMRep -> HeapOffset
varHdrSize :: SMRep -> HeapOffset
zeroOff :: HeapOffset
writeRealC :: (GlobalSwitch -> Bool) -> _FILE -> AbstractC -> _State _RealWorld -> ((), _State _RealWorld)
instance Eq MagicId
instance Eq BasicLit
instance Eq CLabel
instance Eq GlobalSwitch
instance Eq SimplifierSwitch
instance Eq Id
instance Eq PrimKind
instance Eq PrimOp
instance Eq Unique
instance Ord BasicLit
instance Ord CLabel
instance Ord GlobalSwitch
instance Ord SimplifierSwitch
instance Ord Id
instance Ord PrimKind
instance Ord Unique
instance NamedThing Id
instance (Outputable a, Outputable b) => Outputable (a, b)
instance (Outputable a, Outputable b, Outputable c) => Outputable (a, b, c)
instance Outputable BasicLit
instance Outputable Bool
instance Outputable Id
instance Outputable PrimKind
instance Outputable PrimOp
instance Outputable a => Outputable (StgAtom a)
instance (Outputable a, Outputable b, Ord b) => Outputable (StgExpr a b)
instance Outputable a => Outputable [a]
instance Text CExprMacro
instance Text CStmtMacro
instance Text Unique
This diff is collapsed.
This module deals with printing (a) C string literals and (b) C labels.
\begin{code}
#include "HsVersions.h"
module CStrings(
cSEP,
pp_cSEP,
identToC, modnameToC,
stringToC, charToC,
charToEasyHaskell
) where
CHK_Ubiq() -- debugging consistency check
import Pretty
import Unpretty( uppChar )
\end{code}
\begin{verbatim}
_ is the main separator
orig becomes
**** *******
_ Zu
' Zq (etc for ops ??)
<funny char> Z[hex-digit][hex-digit]
Prelude<x> ZP<x>
<std class> ZC<?>
<std tycon> ZT<?>
\end{verbatim}
\begin{code}
cSEP = SLIT("_") -- official C separator
pp_cSEP = uppChar '_'
identToC :: FAST_STRING -> Pretty
modnameToC :: FAST_STRING -> FAST_STRING
stringToC :: String -> String
charToC, charToEasyHaskell :: Char -> String
-- stringToC: the hassle is what to do w/ strings like "ESC 0"...
stringToC "" = ""
stringToC [c] = charToC c
stringToC (c:cs)
-- if we have something "octifiable" in "c", we'd better "octify"
-- the rest of the string, too.
= if (c < ' ' || c > '~')
then (charToC c) ++ (concat (map char_to_C cs))
else (charToC c) ++ (stringToC cs)
where
char_to_C c | c == '\n' = "\\n" -- use C escapes when we can
| c == '\a' = "\\a"
| c == '\b' = "\\b" -- ToDo: chk some of these...
| c == '\r' = "\\r"
| c == '\t' = "\\t"
| c == '\f' = "\\f"
| c == '\v' = "\\v"
| otherwise = '\\' : (octify (ord c))
charToC c = if (c >= ' ' && c <= '~') -- non-portable...
then case c of
'\'' -> "\\'"
'\\' -> "\\\\"
'"' -> "\\\""
'\n' -> "\\n"
'\a' -> "\\a"
'\b' -> "\\b"
'\r' -> "\\r"
'\t' -> "\\t"
'\f' -> "\\f"
'\v' -> "\\v"
_ -> [c]
else '\\' : (octify (ord c))
-- really: charToSimpleHaskell
charToEasyHaskell c
= if (c >= 'a' && c <= 'z')
|| (c >= 'A' && c <= 'Z')
|| (c >= '0' && c <= '9')
then [c]
else case c of
_ -> '\\' : 'o' : (octify (ord c))
octify :: Int -> String
octify n
= if n < 8 then
[chr (n + ord '0')]
else
octify (n `quot` 8) ++ [chr (n `rem` 8 + ord '0')]
identToC ps
= let
str = _UNPK_ ps
in
ppBeside
(case str of
's':'t':'d':_ -> -- avoid "stdin", "stdout", and "stderr"...
ppChar 'Z'
_ -> ppNil)
(if (all isAlphanum str) -- we gamble that this test will succeed...
then ppPStr ps
else ppIntersperse ppNil (map char_to_c str))
where
char_to_c 'Z' = ppPStr SLIT("ZZ")
char_to_c '&' = ppPStr SLIT("Za")
char_to_c '|' = ppPStr SLIT("Zb")
char_to_c ':' = ppPStr SLIT("Zc")
char_to_c '/' = ppPStr SLIT("Zd")
char_to_c '=' = ppPStr SLIT("Ze")
char_to_c '>' = ppPStr SLIT("Zg")
char_to_c '#' = ppPStr SLIT("Zh")
char_to_c '<' = ppPStr SLIT("Zl")
char_to_c '-' = ppPStr SLIT("Zm")
char_to_c '!' = ppPStr SLIT("Zn")
char_to_c '.' = ppPStr SLIT("Zo")
char_to_c '+' = ppPStr SLIT("Zp")
char_to_c '\'' = ppPStr SLIT("Zq")
char_to_c '*' = ppPStr SLIT("Zt")
char_to_c '_' = ppPStr SLIT("Zu")
char_to_c c = if isAlphanum c
then ppChar c
else ppBeside (ppChar 'Z') (ppInt (ord c))
\end{code}
For \tr{modnameToC}, we really only have to worry about \tr{'}s (quote
chars) in the name. Rare.
\begin{code}
modnameToC ps
= let
str = _UNPK_ ps
in
if not (any quote_here str) then
ps
else
_PK_ (concat (map char_to_c str))
where
quote_here '\'' = True
quote_here _ = False
char_to_c c
= if isAlphanum c then [c] else 'Z' : (show (ord c))
\end{code}
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface Costs where
import AbsCSyn(AbstractC, CAddrMode)
data CostRes = Cost (Int, Int, Int, Int, Int)
data Side = Lhs | Rhs
addrModeCosts :: CAddrMode -> Side -> CostRes
costs :: AbstractC -> CostRes
nullCosts :: CostRes
instance Eq CostRes
instance Num CostRes
instance Text CostRes
This diff is collapsed.
{-# GHC_PRAGMA INTERFACE VERSION 5 #-}
interface HeapOffs where
import CharSeq(CSeq)
import MachDesc(Target)
import Maybes(Labda)
import Pretty(PprStyle)
import SMRep(SMRep)
data HeapOffset
type HpRelOffset = HeapOffset
type SpARelOffset = Int
type SpBRelOffset = Int
type VirtualHeapOffset = HeapOffset
type VirtualSpAOffset = Int
type VirtualSpBOffset = Int
addOff :: HeapOffset -> HeapOffset -> HeapOffset
fixedHdrSize :: HeapOffset
hpRelToInt :: Target -> HeapOffset -> Int
intOff :: Int -> HeapOffset
intOffsetIntoGoods :: HeapOffset -> Labda Int
isZeroOff :: HeapOffset -> Bool
maxOff :: HeapOffset -> HeapOffset -> HeapOffset
possiblyEqualHeapOffset :: HeapOffset -> HeapOffset -> Bool
pprHeapOffset :: PprStyle -> HeapOffset -> CSeq
subOff :: HeapOffset -> HeapOffset -> HeapOffset
totHdrSize :: SMRep -> HeapOffset
varHdrSize :: SMRep -> HeapOffset
zeroOff :: HeapOffset
% %
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
% %
\section[HeapOffs]{Abstract C: heap offsets} \section[HeapOffs]{Abstract C: heap offsets}
...@@ -12,11 +12,7 @@ INTERNAL MODULE: should be accessed via @AbsCSyn.hi@. ...@@ -12,11 +12,7 @@ INTERNAL MODULE: should be accessed via @AbsCSyn.hi@.
#include "HsVersions.h" #include "HsVersions.h"
module HeapOffs ( module HeapOffs (
#ifndef DPH
HeapOffset, HeapOffset,
#else
HeapOffset(..), -- DPH needs to do a little peaking inside this thing.
#endif {- Data Parallel Haskell -}
zeroOff, intOff, fixedHdrSize, totHdrSize, varHdrSize, zeroOff, intOff, fixedHdrSize, totHdrSize, varHdrSize,
maxOff, addOff, subOff, maxOff, addOff, subOff,
...@@ -26,24 +22,27 @@ module HeapOffs ( ...@@ -26,24 +22,27 @@ module HeapOffs (
intOffsetIntoGoods, intOffsetIntoGoods,
#if 0
#if ! OMIT_NATIVE_CODEGEN #if ! OMIT_NATIVE_CODEGEN
hpRelToInt, hpRelToInt,
#endif
#endif #endif
VirtualHeapOffset(..), HpRelOffset(..), VirtualHeapOffset(..), HpRelOffset(..),
VirtualSpAOffset(..), VirtualSpBOffset(..), VirtualSpAOffset(..), VirtualSpBOffset(..),
SpARelOffset(..), SpBRelOffset(..) SpARelOffset(..), SpBRelOffset(..)
) where ) where
import Ubiq{-uitous-}
import ClosureInfo -- esp. about SMReps import ClosureInfo ( isSpecRep )
import SMRep import Maybes ( catMaybes )
import SMRep
import Unpretty -- ********** NOTE **********
import Util ( panic )
#if ! OMIT_NATIVE_CODEGEN #if ! OMIT_NATIVE_CODEGEN
import MachDesc --import MachDesc ( Target )
#endif #endif
import Maybes ( catMaybes, Maybe(..) )
import Outputable
import Unpretty -- ********** NOTE **********
import Util
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -63,7 +62,7 @@ import Util ...@@ -63,7 +62,7 @@ import Util
* Node, the ptr to the closure, pts at its info-ptr field * Node, the ptr to the closure, pts at its info-ptr field
-} -}
data HeapOffset data HeapOffset
= MkHeapOffset = MkHeapOffset
FAST_INT -- this many words... FAST_INT -- this many words...
...@@ -88,13 +87,8 @@ data HeapOffset ...@@ -88,13 +87,8 @@ data HeapOffset
deriving () -- but: see `eqOff` below deriving () -- but: see `eqOff` below
#if defined(__GLASGOW_HASKELL__)
data SMRep__Int = SMRI_ SMRep Int# data SMRep__Int = SMRI_ SMRep Int#
#define SMRI(a,b) (SMRI_ a b) #define SMRI(a,b) (SMRI_ a b)
#else
type SMRep__Int = (SMRep, Int)
#define SMRI(a,b) (a, b)
#endif
type VirtualHeapOffset = HeapOffset type VirtualHeapOffset = HeapOffset
type VirtualSpAOffset = Int type VirtualSpAOffset = Int