Commit 8f7ac3fe authored by simonpj's avatar simonpj
Browse files

[project @ 1997-01-06 21:08:42 by simonpj]

Pragmas in interface files added
parent b437dc06
# -----------------------------------------------------------------------------
# $Id: Makefile,v 1.5 1996/12/19 09:10:03 simonpj Exp $
# $Id: Makefile,v 1.6 1997/01/06 21:08:42 simonpj Exp $
TOP = ../..
FlexSuffixRules = YES
......@@ -155,9 +155,9 @@ endif
all :: hsc libhsp.a
hsc : $(OBJS)
# $(HC) -no-link-chk "-pgml time /projects/pacsoft/ghc/src/pureatria/purelink-1.2.2-solaris2/purelink gcc" $(HC_OPTS) -o $@ $^
$(HC) -no-link-chk "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" $(HC_OPTS) -o $@ $^
# $(HC) -no-link-chk "-pgml time gcc" $(HC_OPTS) -o $@ $^
# $(HC) -no-link-chk "-pgml time /projects/pacsoft/ghc/src/pureatria/purelink-1.2.2-solaris2/purelink gcc" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^
$(HC) -no-link-chk "-pgml time gcc -B/projects/unsupported/gnu/sparc-sunos5/bin/g" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^
# $(HC) -no-link-chk "-pgml time gcc" $(HC_OPTS) $(EXTRA_HC_OPTS) -o $@ $^
parser/hschooks.o : parser/hschooks.c
@$(RM) $@
......@@ -165,7 +165,7 @@ parser/hschooks.o : parser/hschooks.c
rename/ParseIface.hs : rename/ParseIface.y
@$(RM) rename/ParseIface.hs rename/ParseIface.hinfo
happy +RTS -K2m -RTS -g rename/ParseIface.y
happy +RTS -K2m -H10m -RTS -g rename/ParseIface.y
@chmod 444 rename/ParseIface.hs
# ----------------------------------------------------------------------------
......
......@@ -92,7 +92,7 @@ charToEasyHaskell c
|| (c >= '0' && c <= '9')
then [c]
else case c of
_ -> '\\' : 'o' : (octify (ord c))
_ -> '\\' : show (ord c)
octify :: Int -> String
octify n
......
......@@ -53,7 +53,7 @@ module Id (
recordSelectorFieldLabel,
-- PREDICATES
wantIdSigInIface,
omitIfaceSigForId,
cmpEqDataCon,
cmpId,
cmpId_withSpecDataCon,
......@@ -153,7 +153,7 @@ import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClas
import IdInfo
import Maybes ( maybeToBool )
import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName,
mkCompoundName, mkInstDeclName, mkWiredInIdName, mkGlobalName,
mkCompoundName, mkInstDeclName,
isLocallyDefinedName, occNameString, modAndOcc,
isLocallyDefined, changeUnique, isWiredInName,
nameString, getOccString, setNameVisibility,
......@@ -551,44 +551,35 @@ idHasNoFreeTyVars (Id _ _ _ details _ info)
chk (SpecPragmaId _ no_free_tvs) = no_free_tvs
chk (PrimitiveId _) = True
-- wantIdSigInIface decides whether to put an Id's type signature and
-- IdInfo in an interface file
wantIdSigInIface
:: Bool -- True <=> the thing is mentioned somewhere else in the
-- interface file
-> Bool -- True <=> omit anything that doesn't *have* to go
-> Id
-- omitIfaceSigForId tells whether an Id's info is implied by other declarations,
-- so we don't need to put its signature in an interface file, even if it's mentioned
-- in some other interface unfolding.
omitIfaceSigForId
:: Id
-> Bool
wantIdSigInIface mentioned_already omit_iface_prags (Id _ name _ details _ _)
= chk details
where
chk (LocalId _) = isExported name &&
not (isWiredInName name) -- User-declared thing!
chk ImportedId = False -- Never put imports in interface file
chk (PrimitiveId _) = False -- Ditto, for primitives
omitIfaceSigForId (Id _ name _ details _ _)
| isWiredInName name
= True
| otherwise
= case details of
ImportedId -> True -- Never put imports in interface file
(PrimitiveId _) -> True -- Ditto, for primitives
-- This group is Ids that are implied by their type or class decl;
-- remember that all type and class decls appear in the interface file
chk (DataConId _ _ _ _ _ _ _) = False
chk (TupleConId _) = False -- Ditto
chk (RecordSelId _) = False -- Ditto
chk (SuperDictSelId _ _) = False -- Ditto
chk (MethodSelId _ _) = False -- Ditto
chk (ConstMethodId _ _ _ _) = False -- Scheduled for nuking
chk (DefaultMethodId _ _ _) = False -- Hmm. No, for now
-- DictFunIds are more interesting, they may have IdInfo we can't
-- get from the instance declaration. We emit them if we're gung ho.
-- No need to check the export flag; instance decls are always exposed
chk (DictFunId _ _) = not omit_iface_prags
-- This group are only called out by being mentioned somewhere else
chk (WorkerId unwrkr) = mentioned_already
chk (SpecId _ _ _) = mentioned_already
chk (InstId _) = mentioned_already
chk (SysLocalId _) = mentioned_already
chk (SpecPragmaId _ _) = mentioned_already
-- remember that all type and class decls appear in the interface file.
-- The dfun id must *not* be omitted, because it carries version info for
-- the instance decl
(DataConId _ _ _ _ _ _ _) -> True
(TupleConId _) -> True
(RecordSelId _) -> True
(SuperDictSelId _ _) -> True
(MethodSelId _ _) -> True
other -> False -- Don't omit!
-- NB DefaultMethodIds are not omitted
\end{code}
\begin{code}
......
......@@ -354,7 +354,7 @@ addStrictnessInfo id_info NoStrictnessInfo = id_info
addStrictnessInfo (IdInfo a b d _ e f g h i) strict = IdInfo a b d strict e f g h i
ppStrictnessInfo sty NoStrictnessInfo = ppNil
ppStrictnessInfo sty BottomGuaranteed = ppPStr SLIT("_S_ _!_")
ppStrictnessInfo sty BottomGuaranteed = ppPStr SLIT("_bot_")
ppStrictnessInfo sty (StrictnessInfo wrapper_args wrkr_maybe)
= ppCat [ppPStr SLIT("_S_"), ppStr (showList wrapper_args ""), pp_wrkr]
......
......@@ -28,8 +28,8 @@ import TysPrim ( getPrimRepInfo,
import CStrings ( stringToC, charToC, charToEasyHaskell )
import TysWiredIn ( stringTy )
import Pretty -- pretty-printing stuff
import PprStyle ( PprStyle(..), codeStyle )
import Util ( thenCmp, panic )
import PprStyle ( PprStyle(..), codeStyle, ifaceStyle )
import Util ( thenCmp, panic, pprPanic )
\end{code}
So-called @Literals@ are {\em either}:
......@@ -48,17 +48,24 @@ function applications, etc., etc., has not yet been done.
data Literal
= MachChar Char
| MachStr FAST_STRING
| MachAddr Integer -- whatever this machine thinks is a "pointer"
| MachInt Integer -- for the numeric types, these are
Bool -- True <=> signed (Int#); False <=> unsigned (Word#)
| MachFloat Rational
| MachDouble Rational
| MachLitLit FAST_STRING
PrimRep
| NoRepStr FAST_STRING -- the uncommitted ones
| NoRepInteger Integer Type{-save what we learned in the typechecker-}
| NoRepRational Rational Type{-ditto-}
| NoRepStr FAST_STRING
| NoRepInteger Integer Type -- This Type is always Integer
| NoRepRational Rational Type -- This Type is always Rational
-- We keep these Types in the literal because Rational isn't
-- (currently) wired in, so we can't conjure up its type out of
-- thin air. Integer is, so the type here is really redundant.
-- deriving (Eq, Ord): no, don't want to compare Types
-- The Ord is needed for the FiniteMap used in the lookForConstructor
......@@ -164,6 +171,11 @@ ppCast :: PprStyle -> FAST_STRING -> Pretty
ppCast PprForC cast = ppPStr cast
ppCast _ _ = ppNil
-- MachX (i.e. unboxed) things are printed unadornded (e.g. 3, 'a', "foo")
-- exceptions: MachFloat and MachAddr get an initial keyword prefix
--
-- NoRep things get an initial keyword prefix (e.g. _integer_ 3)
instance Outputable Literal where
ppr sty (MachChar ch)
= let
......@@ -171,64 +183,54 @@ instance Outputable Literal where
= case sty of
PprForC -> charToC ch
PprForAsm _ _ -> charToC ch
PprUnfolding -> charToEasyHaskell ch
PprInterface -> charToEasyHaskell ch
_ -> [ch]
in
ppBeside (ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\''])
(if_ubxd sty)
ppBesides [ppCast sty SLIT("(C_)"), ppChar '\'', ppStr char_encoding, ppChar '\'']
ppr sty (MachStr s)
= ppBeside (if codeStyle sty
then ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"']
else ppStr (show (_UNPK_ s)))
(if_ubxd sty)
| codeStyle sty = ppBesides [ppChar '"', ppStr (stringToC (_UNPK_ s)), ppChar '"']
| otherwise = ppStr (show (_UNPK_ s))
ppr sty lit@(NoRepStr s)
| codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
| otherwise = ppBesides [ppStr "_string_", ppStr (show (_UNPK_ s))]
ppr sty (MachAddr p) = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p, if_ubxd sty]
ppr sty (MachInt i signed)
| codeStyle sty
&& ((signed && (i >= toInteger minInt && i <= toInteger maxInt))
|| (not signed && (i >= toInteger 0 && i <= toInteger maxInt)))
-- ToDo: Think about these ranges!
= ppBesides [ppInteger i, if_ubxd sty]
| not (codeStyle sty) -- we'd prefer the code to the error message
= ppBesides [ppInteger i, if_ubxd sty]
| otherwise
= error ("ERROR: Int " ++ show i ++ " out of range [" ++
show range_min ++ " .. " ++ show maxInt ++ "]\n")
| codeStyle sty && out_of_range
= panic ("ERROR: Int " ++ show i ++ " out of range [" ++
show range_min ++ " .. " ++ show range_max ++ "]\n")
| otherwise = ppInteger i
where
range_min = if signed then minInt else 0
range_max = maxInt
out_of_range = not (i >= toInteger range_min && i <= toInteger range_max)
ppr sty (MachFloat f) = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f, if_ubxd sty]
ppr sty (MachDouble d) = ppBesides [ppRational d, if_ubxd sty, if_ubxd sty]
ppr sty (NoRepInteger i _)
| codeStyle sty = ppInteger i
| ufStyle sty = ppCat [ppStr "_NOREP_I_", ppInteger i]
| otherwise = ppBesides [ppInteger i, ppChar 'I']
ppr sty (MachFloat f)
| codeStyle sty = ppBesides [ppCast sty SLIT("(StgFloat)"), ppRational f]
| otherwise = ppBesides [ppStr "_float_", ppRational f]
ppr sty (NoRepRational r _)
| ufStyle sty = ppCat [ppStr "_NOREP_R_", ppInteger (numerator r), ppInteger (denominator r)]
| codeStyle sty = panic "ppr.ForC.NoRepRational"
| otherwise = ppBesides [ppRational r, ppChar 'R']
ppr sty (MachDouble d) = ppRational d
ppr sty (NoRepStr s)
| codeStyle sty = ppBesides [ppStr (show (_UNPK_ s))]
| ufStyle sty = ppCat [ppStr "_NOREP_S_", ppStr (show (_UNPK_ s))]
| otherwise = ppBesides [ppStr (show (_UNPK_ s)), ppChar 'S']
ppr sty (MachAddr p)
| codeStyle sty = ppBesides [ppCast sty SLIT("(void*)"), ppInteger p]
| otherwise = ppBesides [ppStr "_addr_", ppInteger p]
ppr sty (MachLitLit s k)
| codeStyle sty = ppPStr s
| ufStyle sty = ppBesides [ppStr "``", ppPStr s, ppStr "'' _K_ ", ppr sty k]
| otherwise = ppBesides [ppStr "``", ppPStr s, ppStr "''"]
ppr sty lit@(NoRepInteger i _)
| codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
| otherwise = ppCat [ppStr "_integer_", ppInteger i]
ufStyle PprUnfolding = True
ufStyle _ = False
ppr sty lit@(NoRepRational r _)
| codeStyle sty = pprPanic "NoRep in code style" (ppr PprDebug lit)
| otherwise = ppCat [ppStr "_rational_", ppInteger (numerator r), ppInteger (denominator r)]
if_ubxd sty = if codeStyle sty then ppNil else ppChar '#'
ppr sty (MachLitLit s k)
| codeStyle sty = ppPStr s
| otherwise = ppBesides [ppStr "_litlit_", ppStr (show (_UNPK_ s))]
showLiteral :: PprStyle -> Literal -> String
showLiteral sty lit = ppShow 80 (ppr sty lit)
\end{code}
......@@ -33,7 +33,7 @@ import AbsCSyn
import CgMonad
import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
import CLabel ( mkClosureLabel )
import CLabel ( mkStaticClosureLabel, mkClosureLabel )
import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument, LambdaFormInfo )
import HeapOffs ( SYN_IE(VirtualHeapOffset),
SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset)
......@@ -291,7 +291,42 @@ getArgAmodes (atom:atoms)
getArgAmode :: StgArg -> FCode CAddrMode
getArgAmode (StgVarArg var) = getCAddrMode var
getArgAmode (StgConArg var)
{- Why does this case differ from StgVarArg?
Because the program might look like this:
data Foo a = Empty | Baz a
f a x = let c = Empty! a
in h c
Now, when we go Core->Stg, we drop the type applications,
so we can inline c, giving
f x = h Empty
Now we are referring to Empty as an argument (rather than in an STGCon),
so we'll look it up with getCAddrMode. We want to return an amode for
the static closure that we make for nullary constructors. But if we blindly
go ahead with getCAddrMode we end up looking in the environment, and it ain't there!
This special case used to be in getCAddrModeAndInfo, but it doesn't work there.
Consider:
f a x = Baz a x
If the constructor Baz isn't inlined we simply want to treat it like any other
identifier, with a top level definition. We don't want to spot that it's a constructor.
In short
StgApp con args
and
StgCon con args
are treated differently; the former is a call to a bog standard function while the
latter uses the specially-labelled, pre-defined info tables etc for the constructor.
The way to think of this case in getArgAmode is that
SApp f Empty
is really
App f (StgCon Empty [])
-}
= returnFC (CLbl (mkStaticClosureLabel var) (idPrimRep var))
getArgAmode (StgVarArg var) = getCAddrMode var -- The common case
getArgAmode (StgLitArg lit) = returnFC (CLit lit)
\end{code}
......
......@@ -80,6 +80,11 @@ Things to be careful about:
\item Adjust the stack high water mark appropriately.
\end{itemize}
\begin{code}
cgTailCall (StgConArg con) args live_vars
= panic "cgTailCall StgConArg" -- Only occur in argument positions
\end{code}
Literals are similar to constructors; they return by putting
themselves in an appropriate register and returning to the address on
top of the B stack.
......
......@@ -68,7 +68,7 @@ import CgRetConv ( assignRegs, dataReturnConvAlg,
)
import CLabel ( mkStdEntryLabel, mkFastEntryLabel,
mkPhantomInfoTableLabel, mkInfoTableLabel,
mkConInfoTableLabel,
mkConInfoTableLabel, mkStaticClosureLabel,
mkBlackHoleInfoTableLabel, mkVapInfoTableLabel,
mkStaticInfoTableLabel, mkStaticConEntryLabel,
mkConEntryLabel, mkClosureLabel, mkVapEntryLabel
......@@ -1177,7 +1177,12 @@ mkConEntryPtr con rep
_ -> mkConEntryLabel con
closureLabelFromCI (MkClosureInfo id _ _) = mkClosureLabel id
closureLabelFromCI (MkClosureInfo id _ rep)
| isConstantRep rep
= mkStaticClosureLabel id
-- This case catches those pesky static closures for nullary constructors
closureLabelFromCI (MkClosureInfo id _ other_rep) = mkClosureLabel id
entryLabelFromCI :: ClosureInfo -> CLabel
entryLabelFromCI (MkClosureInfo id lf_info rep)
......
......@@ -235,6 +235,9 @@ calcUnfoldingGuidance
calcUnfoldingGuidance True bOMB_OUT_SIZE expr = UnfoldAlways -- Always inline if the INLINE pragma says so
calcUnfoldingGuidance False any_size (Con _ _ ) = UnfoldAlways -- We are very gung ho about inlining
calcUnfoldingGuidance False any_size (Lit _) = UnfoldAlways -- constructors and literals
calcUnfoldingGuidance False bOMB_OUT_SIZE expr
= let
(use_binders, ty_binders, val_binders, body) = collectBinders expr
......@@ -460,24 +463,19 @@ okToInline
-> Bool -- True => it's small enough to inline
-> Bool -- True => yes, inline it
-- Always inline bottoms
okToInline BottomForm occ_info small_enough
= True -- Unless one of the type args is unboxed??
-- This used to be checked for, but I can't
-- see why so I've left it out.
-- A WHNF can be inlined if it occurs once, or is small
-- If there's no danger of duplicating work, we can inline if it occurs once, or is small
okToInline form occ_info small_enough
| is_whnf_form form
| no_dup_danger form
= small_enough || one_occ
where
one_occ = case occ_info of
OneOcc _ _ _ n_alts _ -> n_alts <= 1
other -> False
is_whnf_form VarForm = True
is_whnf_form ValueForm = True
is_whnf_form other = False
no_dup_danger VarForm = True
no_dup_danger ValueForm = True
no_dup_danger BottomForm = True
no_dup_danger other = False
-- A non-WHNF can be inlined if it doesn't occur inside a lambda,
-- and occurs exactly once or
......
......@@ -55,7 +55,9 @@ import UniqSupply ( initUs, returnUs, thenUs,
SYN_IE(UniqSM), UniqSupply
)
import Usage ( SYN_IE(UVar) )
import Util ( zipEqual, panic, pprPanic, assertPanic )
import Util ( zipEqual, panic, pprTrace, pprPanic, assertPanic )
import Pretty
import Outputable ( Outputable(..) )
type TypeEnv = TyVarEnv Type
applyUsage = panic "CoreUtils.applyUsage:ToDo"
......@@ -82,7 +84,14 @@ coreExprType (Coerce _ ty _) = ty -- that's the whole point!
-- a Con is a fully-saturated application of a data constructor
-- a Prim is <ditto> of a PrimOp
coreExprType (Con con args) = applyTypeToArgs (dataConRepType con) args
coreExprType (Con con args) =
-- pprTrace "appTyArgs" (ppCat [ppr PprDebug con, ppSemi,
-- ppr PprDebug con_ty, ppSemi,
-- ppr PprDebug args]) $
applyTypeToArgs con_ty args
where
con_ty = dataConRepType con
coreExprType (Prim op args) = applyTypeToArgs (primOpType op) args
coreExprType (Lam (ValBinder binder) expr)
......@@ -95,7 +104,11 @@ coreExprType (Lam (UsageBinder uvar) expr)
= mkForAllUsageTy uvar (panic "coreExprType:Lam UsageBinder") (coreExprType expr)
coreExprType (App expr (TyArg ty))
= applyTy (coreExprType expr) ty
=
-- pprTrace "appTy1" (ppCat [ppr PprDebug fun_ty, ppSP, ppr PprDebug ty]) $
applyTy fun_ty ty
where
fun_ty = coreExprType expr
coreExprType (App expr (UsageArg use))
= applyUsage (coreExprType expr) use
......
......@@ -36,7 +36,7 @@ import Name ( OccName, parenInCode )
import Outputable -- quite a few things
import PprEnv
import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} )
import PprStyle ( PprStyle(..) )
import PprStyle ( PprStyle(..), ifaceStyle )
import Pretty
import PrimOp ( PrimOp{-instances-} )
import TyVar ( GenTyVar{-instances-} )
......@@ -85,15 +85,27 @@ pprGenCoreBinding sty pbdr1 pbdr2 pocc bind
init_ppr_env sty tvbndr pbdr1 pbdr2 pocc
= initPprEnv sty
(Just (ppr sty)) -- literals
(Just (ppr sty)) -- data cons
(Just (ppr sty)) -- primops
(Just ppr_con) -- data cons
(Just ppr_prim) -- primops
(Just (\ cc -> ppStr (showCostCentre sty True cc)))
(Just tvbndr) -- tyvar binders
(Just (ppr sty)) -- tyvar occs
(Just (ppr sty)) -- usage vars
(Just tvbndr) -- tyvar binders
(Just (ppr sty)) -- tyvar occs
(Just (ppr sty)) -- usage vars
(Just pbdr1) (Just pbdr2) (Just pocc) -- value vars
(Just (pprParendGenType sty)) -- types
(Just (ppr sty)) -- usages
(Just (ppr sty)) -- usages
where
-- ppr_con is used when printing Con expressions; we add a "!"
-- to distinguish them from ordinary applications. But not when
-- printing for interfaces, where they are treated as ordinary applications
ppr_con con | ifaceStyle sty = ppr sty con
| otherwise = ppr sty con `ppBeside` ppChar '!'
-- We add a "!" to distinguish Primitive applications from ordinary applications.
-- But not when printing for interfaces, where they are treated
-- as ordinary applications
ppr_prim prim | ifaceStyle sty = ppr sty prim
| otherwise = ppr sty prim `ppBeside` ppChar '!'
--------------
pprCoreBinding sty (NonRec binder expr)
......@@ -243,11 +255,11 @@ ppr_expr pe (Lit lit) = pLit pe lit
ppr_expr pe (Con con []) = pCon pe con
ppr_expr pe (Con con args)
= ppHang (ppBesides [pCon pe con, ppChar '!'])
= ppHang (pCon pe con)
4 (ppSep (map (ppr_arg pe) args))
ppr_expr pe (Prim prim args)
= ppHang (ppBesides [pPrim pe prim, ppChar '!'])
= ppHang (pPrim pe prim)
4 (ppSep (map (ppr_arg pe) args))
ppr_expr pe expr@(Lam _ _)
......@@ -263,15 +275,13 @@ ppr_expr pe expr@(Lam _ _)
pp_vars lam pp vs
= ppCat [ppPStr lam, ppInterleave ppSP (map pp vs), ppStr "->"]
ppr_expr pe expr@(App _ _)
ppr_expr pe expr@(App fun arg)
= let
(fun, uargs, targs, vargs) = collectArgs expr
(final_fun, final_args) = go fun [arg]
go (App fun arg) args_so_far = go fun (arg:args_so_far)
go fun args_so_far = (fun, args_so_far)
in
ppHang (ppr_parend_expr pe fun)
4 (ppSep [ ppInterleave ppNil (map (pUse pe) uargs)
, ppInterleave ppNil (map (pTy pe) targs)
, ppInterleave ppNil (map (ppr_arg pe) vargs)
])
ppHang (ppr_parend_expr pe final_fun) 4 (ppSep (map (ppr_arg pe) final_args))
ppr_expr pe (Case expr alts)
| only_one_alt alts
......@@ -282,7 +292,7 @@ ppr_expr pe (Case expr alts)
ppr_alt (PrimAlts [] (BindDefault n _)) = ppBeside (pMinBndr pe n) (ppStr " ->")
ppr_alt (PrimAlts ((l, _):[]) NoDefault)= ppBeside (pLit pe l) (ppStr " ->")
ppr_alt (AlgAlts ((con, params, _):[]) NoDefault)
= ppCat [ppr_alt_con con (pCon pe con),
= ppCat [pCon pe con,
ppInterleave ppSP (map (pMinBndr pe) params),
ppStr "->"]
......@@ -292,14 +302,18 @@ ppr_expr pe (Case expr alts)
ppr_rhs (PrimAlts ((_,expr):[]) NoDefault) = ppr_expr pe expr
in
ppSep
[ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts],
ppBeside (ppr_rhs alts) (ppStr ";}")]
[ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {", ppr_alt alts],
ppBeside (ppr_rhs alts) (ppStr ";}")]
| otherwise -- default "case" printing
= ppSep
[ppSep [ppPStr SLIT("case"), ppNest 4 (ppr_expr pe expr), ppStr "of {"],
[ppSep [pp_keyword, ppNest 4 (ppr_expr pe expr), ppStr "of {"],
ppNest 2 (ppr_alts pe alts),
ppStr "}"]
where
pp_keyword = case alts of
AlgAlts _ _ -> ppPStr SLIT("case")
PrimAlts _ _ -> ppPStr SLIT("case#")
-- special cases: let ... in let ...
-- ("disgusting" SLPJ)
......@@ -333,18 +347,16 @@ ppr_expr pe (SCC cc expr)
ppr_parend_expr pe expr ]
ppr_expr pe (Coerce c ty expr)
= ppSep [pp_coerce c, pTy pe ty, ppr_parend_expr pe expr ]
= ppSep [pp_coerce c, pTy pe ty, ppr_expr pe expr]
where
pp_coerce (CoerceIn v) = ppBeside (ppStr "_coerce_in_") (ppr (pStyle pe) v)
pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_") (ppr (pStyle pe) v)
pp_coerce (CoerceIn v) = ppBeside (ppStr "_coerce_in_ ") (ppr (pStyle pe) v)
pp_coerce (CoerceOut v) = ppBeside (ppStr "_coerce_out_ ") (ppr (pStyle pe) v)
only_one_alt (AlgAlts [] (BindDefault _ _)) = True
only_one_alt (AlgAlts (_:[]) NoDefault) = True
only_one_alt (PrimAlts [] (BindDefault _ _)) = True
only_one_alt (PrimAlts (_:[]) NoDefault) = True
only_one_alt _ = False
ppr_alt_con con pp_con = if parenInCode (getOccName con) then ppParens pp_con else pp_con
\end{code}
\begin{code}
......@@ -356,7 +368,7 @@ ppr_alts pe (AlgAlts alts deflt)
ppCat [ppParens (ppInterleave ppComma (map (pMinBndr pe) params)),
ppStr "->"]
else
ppCat [ppr_alt_con con (pCon pe con),
ppCat [pCon pe con,
ppInterleave ppSP (map (pMinBndr pe) params),
ppStr "->"]
)
......@@ -381,7 +393,7 @@ ppr_default pe (BindDefault val_bdr expr)
\begin{code}
ppr_arg pe (LitArg lit) = pLit pe lit
ppr_arg pe (VarArg v) = pOcc pe v
ppr_arg pe (TyArg ty) = pTy pe ty
ppr_arg pe (TyArg ty) = ppStr "@ " `ppBeside` pTy pe ty
ppr_arg pe (UsageArg use) = pUse pe use
\end{code}
......
......@@ -98,7 +98,7 @@ dsCCall label args may_gc is_asm result_ty
\begin{code}
unboxArg :: CoreExpr -- The supplied argument
-> DsM (CoreExpr, -- To pass as the actual argument
-> DsM (CoreExpr, -- To pass as the actual argument
CoreExpr -> CoreExpr -- Wrapper to unbox the arg
)
unboxArg arg
......@@ -106,6 +106,13 @@ unboxArg arg
-- Primitive types
-- ADR Question: can this ever be used? None of the PrimTypes are
-- instances of the CCallable class.
--
-- SOF response:
-- Oh yes they are, I've just added them :-) Having _ccall_ and _casm_
-- that accept unboxed arguments is a Good Thing if you have a stub generator
-- which generates the boiler-plate box-unbox code for you, i.e., it may help
-- us nuke this very module :-)
--
| isPrimType arg_ty
= returnDs (arg, \body -> body)
......
......@@ -310,23 +310,6 @@ dsExpr (ExplicitTuple expr_list)
mkConDs (tupleCon (length expr_list))
(map (TyArg . coreExprType) core_exprs ++ map VarArg core_exprs)
-- Two cases, one for ordinary constructors and one for newtype constructors
dsExpr (HsCon con tys args)
| isDataTyCon tycon -- The usual datatype case
= mapDs dsExpr args `thenDs` \ args_exprs ->
mkConDs con (map TyArg tys ++ map VarArg args_exprs)
| otherwise -- The newtype case
= ASSERT( isNewTyCon tycon )
ASSERT( null rest_args )
dsExpr first_arg `thenDs` \ arg_expr ->