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!
#ifdef DEBUG
#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
#define CHK_Ubiq() import Ubiq
#else
#define ASSERT(e)
#define CHK_Ubiq()
#endif
-- 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
......@@ -57,10 +57,10 @@ module Costs( costs,
addrModeCosts, CostRes(Cost), nullCosts, Side(..)
) where
import AbsCFuns
import AbsCUtils
import AbsCSyn
import AbsPrel
import PrimOps
import PrelInfo
import PrimOp
import TyCon
import Util
......@@ -493,23 +493,23 @@ primOpCosts primOp
-- ---------------------------------------------------------------------------
{- HWL: currently unused
costsByKind :: PrimKind -> Side -> CostRes
costsByKind :: PrimRep -> Side -> CostRes
-- The following PrimKinds say that the data is already in a reg
costsByKind CharKind _ = nullCosts
costsByKind IntKind _ = nullCosts
costsByKind WordKind _ = nullCosts
costsByKind AddrKind _ = nullCosts
costsByKind FloatKind _ = nullCosts
costsByKind DoubleKind _ = nullCosts
costsByKind CharRep _ = nullCosts
costsByKind IntRep _ = nullCosts
costsByKind WordRep _ = nullCosts
costsByKind AddrRep _ = nullCosts
costsByKind FloatRep _ = nullCosts
costsByKind DoubleRep _ = nullCosts
-}
-- ---------------------------------------------------------------------------
#endif {-GRAN-}
\end{code}
This is the data structure of {\tt PrimOp} copied from prelude/PrimOps.lhs.
This is the data structure of {\tt PrimOp} copied from prelude/PrimOp.lhs.
I include here some comments about the estimated costs for these @PrimOps@.
Compare with the @primOpCosts@ fct above. -- HWL
......@@ -591,20 +591,20 @@ data PrimOp
-- primitive ops for primitive arrays
| NewArrayOp
| NewByteArrayOp PrimKind
| NewByteArrayOp PrimRep
| SameMutableArrayOp
| SameMutableByteArrayOp
| ReadArrayOp | WriteArrayOp | IndexArrayOp -- for arrays of Haskell ptrs
| ReadByteArrayOp PrimKind
| WriteByteArrayOp PrimKind
| IndexByteArrayOp PrimKind
| IndexOffAddrOp PrimKind
-- PrimKind can be one of {Char,Int,Addr,Float,Double}Kind.
| ReadByteArrayOp PrimRep
| WriteByteArrayOp PrimRep
| IndexByteArrayOp PrimRep
| IndexOffAddrOp PrimRep
-- PrimRep can be one of {Char,Int,Addr,Float,Double}Kind.
-- This is just a cheesy encoding of a bunch of ops.
-- Note that MallocPtrKind is not included -- the only way of
-- Note that MallocPtrRep is not included -- the only way of
-- creating a MallocPtr is with a ccall or casm.
| UnsafeFreezeArrayOp | UnsafeFreezeByteArrayOp
......@@ -619,9 +619,9 @@ Note: From GrAn point of view, CCall is probably very expensive -- HWL
| CCallOp String -- An "unboxed" ccall# to this named function
Bool -- True <=> really a "casm"
Bool -- True <=> might invoke Haskell GC
[UniType] -- Unboxed argument; the state-token
[Type] -- Unboxed argument; the state-token
-- argument will have been put *first*
UniType -- Return type; one of the "StateAnd<blah>#" types
Type -- Return type; one of the "StateAnd<blah>#" types
-- (... to be continued ... )
\end{pseudocode}
{-# 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}
......@@ -12,11 +12,7 @@ INTERNAL MODULE: should be accessed via @AbsCSyn.hi@.
#include "HsVersions.h"
module HeapOffs (
#ifndef DPH
HeapOffset,
#else
HeapOffset(..), -- DPH needs to do a little peaking inside this thing.
#endif {- Data Parallel Haskell -}
zeroOff, intOff, fixedHdrSize, totHdrSize, varHdrSize,
maxOff, addOff, subOff,
......@@ -26,8 +22,10 @@ module HeapOffs (
intOffsetIntoGoods,
#if 0