Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
jberryman
GHC
Commits
ca5a4a48
Commit
ca5a4a48
authored
May 01, 1996
by
partain
Browse files
[project @ 1996-05-01 18:36:59 by partain]
SLPJ 1.3 changes through 960501
parent
f01a8e8c
Changes
60
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/HsVersions.h
View file @
ca5a4a48
...
...
@@ -10,10 +10,6 @@ you will screw up the layout where they are used in case expressions!
#endif
#define MkInt I#
#define MkChar C#
#define MkArray _Array
#ifdef __GLASGOW_HASKELL__
#define TAG_ Int#
#define LT_ -1#
...
...
@@ -22,58 +18,14 @@ you will screw up the layout where they are used in case expressions!
#endif
#define GT__ _
#ifdef __HBC__
#define IMPORT_Trace import Trace
#define BSCC(l) (
#define ESCC )
#else
#define IMPORT_Trace {--}
#define BSCC(l) (_scc_ l (
#define ESCC ))
#endif
--
these
are
overridable
#ifndef BIND
#define BIND case
#endif
/* BIND */
#ifndef _TO_
#define _TO_ of {
#endif
/* _TO_ */
#ifndef BEND
#define BEND }
#endif
/* BEND */
#ifndef RETN
#define RETN {--}
#endif
/* RETN */
#ifndef RETN_TYPE
#define RETN_TYPE {--}
#endif
/* RETN_TYPE */
#define COMMA ,
#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
ATTACK_PRAGMA
stuff
encourages
Utils
.
lhs
to
tell
--
everyone
about
everyone
else
.
I
guess
we
need
to
add
some
--
more
conditional
stuff
in
.
#ifdef USE_ATTACK_PRAGMAS
#define IF_ATTACK_PRAGMAS(x) x
#else
#define IF_ATTACK_PRAGMAS(x) {--}
#endif
#if GHCI
#define IF_GHCI(stuff) stuff
#else
#define IF_GHCI(stuff) {-nothing-}
#endif
#define CHK_Ubiq() import Ubiq
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 26
#define trace _trace
...
...
@@ -157,24 +109,4 @@ you will screw up the layout where they are used in case expressions!
#define _CONCAT_ concat
#endif
#if __HASKELL1__ < 3
{
-
To
avoid
confusion
with
Haskell
1
.
3
,
we
use
Swahili
.
data
Maybe
a
=
Nothing
|
Just
a
data
Labda
a
=
Hamna
|
Ni
a
Should
we
ever
need
to
increase
confusion
with
HBC
,
we
will
use
Swedish
:
data
Kanske
a
=
Ingenting
|
Bara
a
-
}
# define Maybe Labda
# define Just Ni
# define Nothing Hamna
#else
# define MAYBE Labda
# define JUST Ni
# define NOTHING Hamna
#endif
#endif
ghc/compiler/Jmakefile
View file @
ca5a4a48
...
...
@@ -377,7 +377,7 @@ ALLINTS=$(ALLSRCS_LHS:.lhs=.hi) $(ALLSRCS_HS:.hs=.hi)
#endif
#if GhcWithHscOptimised == YES
#define __version_sensitive_flags -DUSE_ATTACK_PRAGMAS -fshow-pragma-name-errs -fomit-reexported-instances -fshow-import-specs
#define __version_sensitive_flags
-O /*
-DUSE_ATTACK_PRAGMAS -fshow-pragma-name-errs
*/
-fomit-reexported-instances -fshow-import-specs
#else
#define __version_sensitive_flags -fomit-reexported-instances
#endif
...
...
ghc/compiler/absCSyn/AbsCUtils.lhs
View file @
ca5a4a48
...
...
@@ -66,39 +66,14 @@ mkAbsCStmts :: AbstractC -> AbstractC -> AbstractC
mkAbsCStmts = AbsCStmts
{- Discarded SLPJ June 95; it calls nonemptyAbsC too much!
=
BIND
(case (nonemptyAbsC abc2) of
=
case
(case (nonemptyAbsC abc2) of
Nothing -> AbsCNop
Just d2 -> d2)
_TO_
abc2b ->
Just d2 -> d2)
of {
abc2b ->
case (nonemptyAbsC abc1) of {
Nothing -> abc2b;
Just d1 -> AbsCStmts d1 abc2b
} BEND
-}
{-
= case (nonemptyAbsC abc1) of
Nothing -> abc2
Just d1 -> AbsCStmts d1 abc2
-}
{- old2:
= case (nonemptyAbsC abc1) of
Nothing -> case (nonemptyAbsC abc2) of
Nothing -> AbsCNop
Just d2 -> d2
Just d1 -> AbsCStmts d1 abc2
-}
{- old:
if abc1_empty then
if abc2_empty
then AbsCNop
else abc2
else if {- abc1 not empty but -} abc2_empty then
abc1
else {- neither empty -}
AbsCStmts abc1 abc2
where
abc1_empty = noAbsCcode abc1
abc2_empty = noAbsCcode abc2
} }
-}
\end{code}
...
...
@@ -539,14 +514,13 @@ flatAmode (CCode abs_C)
_ ->
-- de-anonymous-ise the code and push it (labelled) to the top level
getUniqFlt `thenFlt` \ new_uniq ->
BIND
(mkReturnPtLabel new_uniq)
_TO_
return_pt_label ->
case
(mkReturnPtLabel new_uniq)
of {
return_pt_label ->
flatAbsC abs_C `thenFlt` \ (body_code, tops) ->
returnFlt (
CLbl return_pt_label CodePtrRep,
tops `mkAbsCStmts` CCodeBlock return_pt_label body_code
-- DO NOT TOUCH the stuff sent to the top...
)
BEND
) }
flatAmode (CTableEntry base index kind)
= flatAmode base `thenFlt` \ (base_amode, base_tops) ->
...
...
ghc/compiler/absCSyn/PprAbsC.lhs
View file @
ca5a4a48
...
...
@@ -210,7 +210,7 @@ pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
the_op = ppr_op_call non_void_results non_void_args
-- liveness mask is *in* the non_void_args
in
BIND
(ppr_vol_regs sty vol_regs)
_TO_
(pp_saves, pp_restores) ->
case
(ppr_vol_regs sty vol_regs)
of {
(pp_saves, pp_restores) ->
if primOpNeedsWrapper op then
uppAboves [ pp_saves,
the_op,
...
...
@@ -218,7 +218,7 @@ pprAbsC sty stmt@(COpStmt results op args liveness_mask vol_regs) _
]
else
the_op
BEND
}
where
ppr_op_call results args
= uppBesides [ prettyToUn (pprPrimOp sty op), uppLparen,
...
...
@@ -246,7 +246,7 @@ pprAbsC sty stmt@(CCallProfCCMacro op as) _
pprAbsC sty (CCodeBlock label abs_C) _
= ASSERT( maybeToBool(nonemptyAbsC abs_C) )
BIND
(pprTempAndExternDecls abs_C)
_TO_
(pp_temps, pp_exts) ->
case
(pprTempAndExternDecls abs_C)
of {
(pp_temps, pp_exts) ->
uppAboves [
uppBesides [uppStr (if (externallyVisibleCLabel label)
then "FN_(" -- abbreviations to save on output
...
...
@@ -259,7 +259,7 @@ pprAbsC sty (CCodeBlock label abs_C) _
uppNest 8 (pprAbsC sty abs_C (costs abs_C)),
uppNest 8 (uppPStr SLIT("FE_")),
uppChar '}' ]
BEND
}
pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
= uppBesides [ pp_init_hdr, uppStr "_HDR(",
...
...
@@ -279,7 +279,7 @@ pprAbsC sty (CInitHdr cl_info reg_rel cost_centre inplace_upd) _
getSMInitHdrStr sm_rep)
pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
=
BIND
(pprTempAndExternDecls stmt)
_TO_
(_, pp_exts) ->
=
case
(pprTempAndExternDecls stmt)
of {
(_, pp_exts) ->
uppAboves [
case sty of
PprForC -> pp_exts
...
...
@@ -296,7 +296,7 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
uppNest 2 (uppBesides (map (ppr_item sty) amodes)),
uppNest 2 (uppBesides (map (ppr_item sty) padding_wds)),
uppStr "};" ]
BEND
}
where
info_lbl = infoTableLabelFromCI cl_info
...
...
@@ -309,9 +309,8 @@ pprAbsC sty stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _
if not (closureUpdReqd cl_info) then
[]
else
BIND (max 0 (mIN_UPD_SIZE - length amodes)) _TO_ still_needed ->
nOfThem still_needed (mkIntCLit 0) -- a bunch of 0s
BEND
case (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed ->
nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s
{-
STATIC_INIT_HDR(c,i,localness) blows into:
...
...
@@ -420,7 +419,7 @@ pprAbsC sty stmt@(CRetUnVector label amode) _
pp_static = if externallyVisibleCLabel label then uppNil else uppPStr SLIT("static")
pprAbsC sty stmt@(CFlatRetVector label amodes) _
=
BIND
(pprTempAndExternDecls stmt)
_TO_
(_, pp_exts) ->
=
case
(pprTempAndExternDecls stmt)
of {
(_, pp_exts) ->
uppAboves [
case sty of
PprForC -> pp_exts
...
...
@@ -428,8 +427,7 @@ pprAbsC sty stmt@(CFlatRetVector label amodes) _
uppBesides [ppLocalness label, uppPStr SLIT(" W_ "),
pprCLabel sty label, uppStr "[] = {"],
uppNest 2 (uppInterleave uppComma (map (ppr_item sty) amodes)),
uppStr "};" ]
BEND
uppStr "};" ] }
where
ppr_item sty item = uppBeside (uppStr "(W_) ") (ppr_amode sty item)
...
...
@@ -444,12 +442,12 @@ ppLocalness label
const = if not (isReadOnly label) then uppNil else uppPStr SLIT("const")
ppLocalnessMacro for_fun{-vs data-} clabel
=
BIND
(if externallyVisibleCLabel clabel then "E" else "I")
_TO_
prefix ->
BIND
(if isReadOnly clabel then "RO_" else "")
_TO_
suffix ->
=
case
(if externallyVisibleCLabel clabel then "E" else "I")
of {
prefix ->
case
(if isReadOnly clabel then "RO_" else "")
of {
suffix ->
if for_fun
then uppStr (prefix ++ "F_")
else uppStr (prefix ++ "D_" ++ suffix)
BEND BEND
} }
\end{code}
\begin{code}
...
...
@@ -1109,10 +1107,9 @@ pprTempAndExternDecls AbsCNop = (uppNil, uppNil)
pprTempAndExternDecls (AbsCStmts stmt1 stmt2)
= initTE (ppr_decls_AbsC stmt1 `thenTE` \ (t_p1, e_p1) ->
ppr_decls_AbsC stmt2 `thenTE` \ (t_p2, e_p2) ->
BIND (catMaybes [t_p1, t_p2]) _TO_ real_temps ->
BIND (catMaybes [e_p1, e_p2]) _TO_ real_exts ->
returnTE (uppAboves real_temps, uppAboves real_exts)
BEND BEND
case (catMaybes [t_p1, t_p2]) of { real_temps ->
case (catMaybes [e_p1, e_p2]) of { real_exts ->
returnTE (uppAboves real_temps, uppAboves real_exts) }}
)
pprTempAndExternDecls other_stmt
...
...
@@ -1214,14 +1211,14 @@ pprExternDecl clabel kind
= if not (needsCDecl clabel) then
uppNil -- do not print anything for "known external" things (e.g., < PreludeCore)
else
BIND
(
case
(
case kind of
CodePtrRep -> ppLocalnessMacro True{-function-} clabel
_
-> ppLocalnessMacro False{-data-} clabel
)
_TO_
pp_macro_str ->
_ -> ppLocalnessMacro False{-data-} clabel
)
of {
pp_macro_str ->
uppBesides [ pp_macro_str, uppLparen, pprCLabel PprForC clabel, pp_paren_semi ]
BEND
}
\end{code}
\begin{code}
...
...
@@ -1385,12 +1382,12 @@ ppr_decls_Amode other = returnTE (Nothing, Nothing)
maybe_uppAboves :: [(Maybe Unpretty, Maybe Unpretty)] -> (Maybe Unpretty, Maybe Unpretty)
maybe_uppAboves ps
=
BIND
(unzip ps)
_TO_
(ts, es) ->
BIND
(catMaybes ts)
_TO_
real_ts ->
BIND
(catMaybes es)
_TO_
real_es ->
=
case
(unzip ps)
of {
(ts, es) ->
case
(catMaybes ts)
of {
real_ts
->
case
(catMaybes es)
of {
real_es
->
(if (null real_ts) then Nothing else Just (uppAboves real_ts),
if (null real_es) then Nothing else Just (uppAboves real_es))
BEND BEND BEND
} } }
\end{code}
\begin{code}
...
...
ghc/compiler/basicTypes/Id.lhs
View file @
ca5a4a48
...
...
@@ -116,7 +116,7 @@ import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
import PragmaInfo ( PragmaInfo(..) )
import PprEnv -- ( NmbrM(..), NmbrEnv(..) )
import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
nmbrType,
add
TyVar,
nmbrType,
nmbr
TyVar,
GenType, GenTyVar
)
import PprStyle
...
...
@@ -1098,11 +1098,10 @@ getIdNamePieces show_uniqs id
get_fullname_pieces :: Name -> [FAST_STRING]
get_fullname_pieces n
=
BIND
(moduleNamePair n)
_TO_
(mod, name) ->
=
case
(moduleNamePair n)
of {
(mod, name) ->
if isPreludeDefinedName n
then [name]
else [mod, name]
BEND
else [mod, name] }
\end{code}
%************************************************************************
...
...
@@ -1375,11 +1374,11 @@ mkDataCon n stricts fields tvs ctxt args_tys tycon
(tyvars, dict_vars, vars) = mk_uf_bits tvs ctxt args_tys tycon
tyvar_tys = mkTyVarTys tyvars
in
BIND
(Con data_con tyvar_tys [VarArg v | v <- vars])
_TO_
plain_Con ->
case
(Con data_con tyvar_tys [VarArg v | v <- vars])
of {
plain_Con ->
mkUnfolding EssentialUnfolding -- for data constructors
(mkLam tyvars (dict_vars ++ vars) plain_Con)
BEND
}
mk_uf_bits tvs ctxt arg_tys tycon
= let
...
...
@@ -1390,19 +1389,19 @@ mkDataCon n stricts fields tvs ctxt args_tys tycon
-- the "context" and "arg_tys" have TyVarTemplates in them, so
-- we instantiate those types to have the right TyVars in them
-- instead.
BIND
(map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
_TO_
inst_dict_tys ->
BIND
(map (instantiateTauTy inst_env) arg_tys)
_TO_
inst_arg_tys ->
case
(map (instantiateTauTy inst_env) (map ctxt_ty ctxt))
of {
inst_dict_tys ->
case
(map (instantiateTauTy inst_env) arg_tys)
of {
inst_arg_tys ->
-- We can only have **ONE** call to mkTemplateLocals here;
-- otherwise, we get two blobs of locals w/ mixed-up Uniques
-- (Mega-Sigh) [ToDo]
BIND
(mkTemplateLocals (inst_dict_tys ++ inst_arg_tys))
_TO_
all_vars ->
case
(mkTemplateLocals (inst_dict_tys ++ inst_arg_tys))
of {
all_vars ->
BIND
(splitAt (length ctxt) all_vars)
_TO_
(dict_vars, vars) ->
case
(splitAt (length ctxt) all_vars)
of {
(dict_vars, vars) ->
(tyvars, dict_vars, vars)
BEND BEND BEND BEND
}}}}
where
-- these are really dubious Types, but they are only to make the
-- binders for the lambdas for tossed-away dicts.
...
...
@@ -1439,17 +1438,14 @@ mkTupleCon arity
(tyvars, dict_vars, vars) = mk_uf_bits arity
tyvar_tys = mkTyVarTys tyvars
in
BIND (Con data_con tyvar_tys [VarArg v | v <- vars]) _TO_ plain_Con ->
case (Con data_con tyvar_tys [VarArg v | v <- vars]) of { plain_Con ->
mkUnfolding
EssentialUnfolding -- data constructors
(mkLam tyvars (dict_vars ++ vars) plain_Con)
BEND
(mkLam tyvars (dict_vars ++ vars) plain_Con) }
mk_uf_bits arity
= BIND (mkTemplateLocals tyvar_tys) _TO_ vars ->
(tyvars, [], vars)
BEND
= case (mkTemplateLocals tyvar_tys) of { vars ->
(tyvars, [], vars) }
where
tyvar_tmpls = take arity alphaTyVars
(_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
...
...
@@ -1824,35 +1820,32 @@ instance NamedThing (GenId ty) where
mod -> (mod, classOpString op)
get (SpecId unspec ty_maybes _)
=
BIND
moduleNamePair unspec
_TO_
(mod, unspec_nm) ->
BIND
specMaybeTysSuffix ty_maybes
_TO_
tys_suffix ->
=
case
moduleNamePair unspec
of {
(mod, unspec_nm) ->
case
specMaybeTysSuffix ty_maybes
of {
tys_suffix ->
(mod,
unspec_nm _APPEND_
(if not (toplevelishId unspec)
then showUnique u
else tys_suffix)
)
BEND BEND
) }}
get (WorkerId unwrkr)
=
BIND
moduleNamePair unwrkr
_TO_
(mod, unwrkr_nm) ->
=
case
moduleNamePair unwrkr
of {
(mod, unwrkr_nm) ->
(mod,
unwrkr_nm _APPEND_
(if not (toplevelishId unwrkr)
then showUnique u
else SLIT(".wrk"))
)
BEND
) }
get other_details
-- the remaining internally-generated flavours of
-- Ids really do not have meaningful "original name" stuff,
-- but we need to make up something (usually for debugging output)
= BIND (getIdNamePieces True this_id) _TO_ (piece1:pieces) ->
BIND [ _CONS_ '.' p | p <- pieces ] _TO_ dotted_pieces ->
(_NIL_, _CONCAT_ (piece1 : dotted_pieces))
BEND BEND
= case (getIdNamePieces True this_id) of { (piece1:pieces) ->
case [ _CONS_ '.' p | p <- pieces ] of { dotted_pieces ->
(_NIL_, _CONCAT_ (piece1 : dotted_pieces)) }}
-}
\end{code}
...
...
@@ -1989,7 +1982,7 @@ nmbrId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
nmbr_details :: IdDetails -> NmbrM IdDetails
nmbr_details (DataConId n tag marks fields tvs theta arg_tys tc)
= mapNmbr
add
TyVar
tvs `thenNmbr` \ new_tvs ->
= mapNmbr
nmbr
TyVar tvs `thenNmbr` \ new_tvs ->
mapNmbr nmbrField fields `thenNmbr` \ new_fields ->
mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys ->
...
...
ghc/compiler/basicTypes/IdInfo.lhs
View file @
ca5a4a48
...
...
@@ -728,7 +728,7 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
\begin{code}
mkUnfolding guide expr
= GenForm False (mkFormSummary NoStrictnessInfo expr)
(
BSCC("OccurExpr")
occurAnalyseGlobalExpr expr
ESCC
)
(occurAnalyseGlobalExpr expr)
guide
\end{code}
...
...
ghc/compiler/basicTypes/Name.lhs
View file @
ca5a4a48
...
...
@@ -350,12 +350,6 @@ exportFlagOn NotExported = False
exportFlagOn _ = True
isExported a = exportFlagOn (getExportFlag a)
#ifdef USE_ATTACK_PRAGMAS
{-# SPECIALIZE isExported :: Class -> Bool #-}
{-# SPECIALIZE isExported :: Id -> Bool #-}
{-# SPECIALIZE isExported :: TyCon -> Bool #-}
#endif
\end{code}
%************************************************************************
...
...
@@ -409,12 +403,6 @@ comparison.]
\begin{code}
a `ltLexical` b = origName a < origName b
#ifdef USE_ATTACK_PRAGMAS
{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
#endif
\end{code}
These functions test strings to see if they fit the lexical categories
...
...
@@ -502,11 +490,4 @@ pprNonSym sty var
= if isSymLexeme var
then ppParens (ppr sty var)
else ppr sty var
#ifdef USE_ATTACK_PRAGMAS
{-# SPECIALIZE isSymLexeme :: Id -> Bool #-}
{-# SPECIALIZE pprNonSym :: PprStyle -> Id -> Pretty #-}
{-# SPECIALIZE pprNonSym :: PprStyle -> TyCon -> Pretty #-}
{-# SPECIALIZE pprSym :: PprStyle -> Id -> Pretty #-}
#endif
\end{code}
ghc/compiler/basicTypes/UniqSupply.lhs
View file @
ca5a4a48
...
...
@@ -67,7 +67,7 @@ getUniques :: Int -> UniqSupply -> [Unique]
\end{code}
\begin{code}
mkSplitUniqSupply (
MkChar
c#)
mkSplitUniqSupply (
C#
c#)
= let
mask# = (i2w (ord# c#)) `shiftL#` (i2w_s 24#)
...
...
@@ -91,7 +91,7 @@ mkSplitUniqSupply (MkChar c#)
(r, s)
mk_unique = _ccall_ genSymZh `thenPrimIO` \ (W# u#) ->
returnPrimIO (
MkInt
(w2i (mask# `or#` u#)))
returnPrimIO (
I#
(w2i (mask# `or#` u#)))
in
mk_supply# `thenPrimIO` \ s ->
return s
...
...
@@ -100,13 +100,13 @@ splitUniqSupply (MkSplitUniqSupply _ s1 s2) = (s1, s2)
\end{code}
\begin{code}
getUnique (MkSplitUniqSupply (
MkInt
n) _ _) = mkUniqueGrimily n
getUnique (MkSplitUniqSupply (
I#
n) _ _) = mkUniqueGrimily n
getUniques
i@(MkInt
i
#
) supply = i
#
`get_from` supply
getUniques
(I#
i) supply = i `get_from` supply
where
get_from 0# _ = []
get_from n
#
(MkSplitUniqSupply (
MkInt
u
#
) _ s2)
= mkUniqueGrimily u
#
: get_from (n
#
`minusInt#` 1#) s2
get_from n (MkSplitUniqSupply (
I#
u) _ s2)
= mkUniqueGrimily u : get_from (n `minusInt#` 1#) s2
\end{code}
%************************************************************************
...
...
ghc/compiler/basicTypes/Unique.lhs
View file @
ca5a4a48
...
...
@@ -252,13 +252,13 @@ w2i x = word2Int# x
i2w x = int2Word# x
i2w_s x = (x::Int#)
mkUnique (
MkChar
c
#
) (
MkInt
i
#
)
= MkUnique (w2i (((i2w (ord# c
#
)) `shiftL#` (i2w_s 24#)) `or#` (i2w i
#
)))
mkUnique (
C#
c) (
I#
i)
= MkUnique (w2i (((i2w (ord# c)) `shiftL#` (i2w_s 24#)) `or#` (i2w i)))
unpkUnique (MkUnique u)
= let
tag =
MkChar
(chr# (w2i ((i2w u) `shiftr` (i2w_s 24#))))
i =
MkInt
(w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
tag =
C#
(chr# (w2i ((i2w u) `shiftr` (i2w_s 24#))))
i =
I#
(w2i ((i2w u) `and#` (i2w 16777215#){-``0x00ffffff''-}))
in
(tag, i)
where
...
...
ghc/compiler/codeGen/ClosureInfo.lhs
View file @
ca5a4a48
...
...
@@ -25,7 +25,7 @@ module ClosureInfo (
layOutDynClosure, layOutDynCon, layOutStaticClosure,
layOutStaticNoFVClosure, layOutPhantomClosure,
mkVirtHeapOffsets,
-- for GHCI
mkVirtHeapOffsets,
nodeMustPointToIt, getEntryConvention,
blackHoleOnEntry,
...
...
ghc/compiler/coreSyn/PprCore.lhs
View file @
ca5a4a48
...
...
@@ -17,7 +17,7 @@ module PprCore (
pprTypedCoreBinder
-- these are here to make the instances go in 0.26:
#if __GLASGOW_HASKELL__ <=
26
#if __GLASGOW_HASKELL__ <=
30
, GenCoreBinding, GenCoreExpr, GenCoreCaseAlts
, GenCoreCaseDefault, GenCoreArg
#endif
...
...
ghc/compiler/deSugar/DsUtils.lhs
View file @
ca5a4a48
...
...
@@ -54,7 +54,7 @@ import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
import PprCore{-ToDo:rm-}
import PprType--ToDo:rm
--
import PprType--ToDo:rm
import Pretty--ToDo:rm
import TyVar--ToDo:rm
import Unique--ToDo:rm
...
...
@@ -422,7 +422,7 @@ The general case:
\begin{code}
mkTupleBind tyvars dicts local_global_prs tuple_expr
= pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
=
--
pprTrace "mkTupleBind:\n" (ppAboves [ppCat (map (pprId PprShowAll) locals), ppCat (map (pprId PprShowAll) globals), {-ppr PprDebug local_tuple, pprType PprDebug res_ty,-} ppr PprDebug tuple_expr]) $
newSysLocalDs tuple_var_ty `thenDs` \ tuple_var ->
...
...
ghc/compiler/deforest/DefExpr.lhs
View file @
ca5a4a48
...
...
@@ -18,7 +18,6 @@
>
import
Type
(
applyTypeEnvToTy
,
isPrimType
,
> SigmaType(..), Type
> IF_ATTACK_PRAGMAS(COMMA cmpUniType)
> )
>
import
CmdLineOpts
(
SwitchResult
,
switchIsOn
)
>
import
CoreUnfold
(
UnfoldingDetails
(
..
)
)
...
...
ghc/compiler/deforest/DefUtils.lhs
View file @
ca5a4a48
...
...
@@ -22,7 +22,6 @@
>
import
Type
(
cloneTyVar
,
mkTyVarTy
,
applyTypeEnvToTy
,
>
tyVarsOfType
,
TyVar
,
SigmaType
(
..
)
> IF_ATTACK_PRAGMAS(COMMA cmpTyVar)
> )
>
import
Literal
(
Literal
)
-- for Eq Literal
>
import
CoreSyn
...
...
ghc/compiler/hsSyn/HsMatches.lhs
View file @
ca5a4a48
...
...
@@ -14,7 +14,7 @@ import Ubiq{-uitous-}
import HsLoop ( HsExpr, nullBinds, HsBinds )
import Outputable ( ifPprShowAll )
import PprType
import PprType
( GenType{-instance Outputable-} )
import Pretty
import SrcLoc ( SrcLoc{-instances-} )
import Util ( panic )
...
...
ghc/compiler/main/CmdLineOpts.lhs
View file @
ca5a4a48
...
...
@@ -221,10 +221,9 @@ opt_AsmTarget = lookup_str "-fasm="
opt_SccGroup = lookup_str "-G="
opt_ProduceC = lookup_str "-C="
opt_ProduceS = lookup_str "-S="
opt_ProduceHi = lookup_str "-hifile="
opt_ProduceHu = lookup_str "-hufile="
opt_MyHi = lookup_str "-myhifile=" -- the ones produced last time
opt_MyHu = lookup_str "-myhufile=" -- for this module
opt_MustRecompile = lookup SLIT("-fmust-recompile")
opt_ProduceHi = lookup_str "-hifile=" -- the one to produce this time
opt_MyHi = lookup_str "-myhifile=" -- the one produced last time
opt_EnsureSplittableC = lookup_str "-fglobalise-toplev-names="
opt_UnfoldingUseThreshold = lookup_int "-funfolding-use-threshold"
opt_UnfoldingCreationThreshold = lookup_int "-funfolding-creation-threshold"
...
...
@@ -234,7 +233,6 @@ opt_ReturnInRegsThreshold = lookup_int "-freturn-in-regs-threshold"
opt_NoImplicitPrelude = lookup SLIT("-fno-implicit-prelude")
opt_IgnoreIfacePragmas = lookup SLIT("-fignore-interface-pragmas")
opt_HuSuffix = case (lookup_str "-husuffix=") of { Nothing -> ".hu" ; Just x -> x }
opt_HiSuffix = case (lookup_str "-hisuffix=") of { Nothing -> ".hi" ; Just x -> x }
opt_SysHiSuffix = case (lookup_str "-syshisuffix=") of { Nothing -> ".hi" ; Just x -> x }
...
...
ghc/compiler/main/Main.lhs
View file @
ca5a4a48
...
...
@@ -33,7 +33,6 @@ import Bag ( emptyBag, isEmptyBag )
import CmdLineOpts
import ErrUtils ( pprBagOfErrors, ghcExit )
import Maybes ( maybeToBool, MaybeErr(..) )
import PrelInfo ( builtinNameInfo )