Commit 2129fa6f authored by simonmar's avatar simonmar
Browse files

[project @ 2003-09-16 13:03:37 by simonmar]

Legacy Removal
~~~~~~~~~~~~~~

The following features have been consigned to the bit bucket:

  _ccall_
  _casm_
  ``....''  (lit-lits)
  the CCallable class
  the CReturnable class
parent ce42f19f
......@@ -31,8 +31,7 @@ import Unique ( Unique{-instance Eq-} )
import UniqSupply ( uniqFromSupply, uniqsFromSupply, splitUniqSupply,
UniqSupply )
import CmdLineOpts ( opt_EmitCExternDecls, opt_Unregisterised )
import ForeignCall ( ForeignCall(..), CCallSpec(..),
isDynamicTarget, isCasmTarget )
import ForeignCall ( ForeignCall(..), CCallSpec(..), isDynamicTarget )
import StgSyn ( StgOp(..) )
import CoreSyn ( AltCon(..) )
import SMRep ( arrPtrsHdrSize, arrWordsHdrSize, fixedHdrSize )
......@@ -343,8 +342,8 @@ flatAbsC (CSwitch discrim alts deflt)
returnFlt ( (tag, alt_heres), alt_tops )
flatAbsC stmt@(COpStmt results (StgFCallOp (CCall ccall@(CCallSpec target _ _)) uniq) args _)
| is_dynamic -- Emit a typedef if its a dynamic call
|| (opt_EmitCExternDecls && not (isCasmTarget target)) -- or we want extern decls
| is_dynamic -- Emit a typedef if its a dynamic call
|| (opt_EmitCExternDecls) -- or we want extern decls
= returnFlt (stmt, CCallTypedef is_dynamic ccall uniq results args)
where
is_dynamic = isDynamicTarget target
......
......@@ -949,7 +949,6 @@ pprFCall call uniq args results vol_regs
call_str tgt
= case tgt of
CasmTarget str -> unpackFS str
StaticTarget fn -> mk_ccall_str (pprCLabelString fn) ccall_args
DynamicTarget -> mk_ccall_str dyn_fun (tail ccall_args)
......
......@@ -8,7 +8,7 @@ module Literal
( Literal(..) -- Exported to ParseIface
, mkMachInt, mkMachWord
, mkMachInt64, mkMachWord64
, isLitLitLit, maybeLitLit, litSize
, litSize
, litIsDupable, litIsTrivial
, literalType, literalPrimRep
, hashLiteral
......@@ -123,16 +123,9 @@ data Literal
-- 'stdcall' labels.
-- Just x => "@<x>" will be appended to label
-- name when emitting asm.
-- lit-lits only work for via-C compilation, hence they
-- are deprecated. The string is emitted verbatim into
-- the C file, and can therefore be any C expression,
-- macro call, #defined constant etc.
| MachLitLit FastString Type -- Type might be Addr# or Int# etc
\end{code}
Binary instance: must do this manually, because we don't want the type
arg of MachLitLit involved.
Binary instance
\begin{code}
instance Binary Literal where
......@@ -146,7 +139,6 @@ instance Binary Literal where
put_ bh (MachFloat ah) = do putByte bh 7; put_ bh ah
put_ bh (MachDouble ai) = do putByte bh 8; put_ bh ai
put_ bh (MachLabel aj mb) = do putByte bh 9; put_ bh aj ; put_ bh mb
put_ bh (MachLitLit ak _) = do putByte bh 10; put_ bh ak
get bh = do
h <- getByte bh
case h of
......@@ -180,9 +172,6 @@ instance Binary Literal where
aj <- get bh
mb <- get bh
return (MachLabel aj mb)
10 -> do
ak <- get bh
return (MachLitLit ak (error "MachLitLit: no type"))
\end{code}
\begin{code}
......@@ -283,12 +272,6 @@ nullAddrLit = MachNullAddr
Predicates
~~~~~~~~~~
\begin{code}
isLitLitLit (MachLitLit _ _) = True
isLitLitLit _ = False
maybeLitLit (MachLitLit s t) = Just (s,t)
maybeLitLit _ = Nothing
litIsTrivial :: Literal -> Bool
-- True if there is absolutely no penalty to duplicating the literal
-- c.f. CoreUtils.exprIsTrivial
......@@ -326,7 +309,6 @@ literalType (MachWord64 _) = word64PrimTy
literalType (MachFloat _) = floatPrimTy
literalType (MachDouble _) = doublePrimTy
literalType (MachLabel _ _) = addrPrimTy
literalType (MachLitLit _ ty) = ty
\end{code}
\begin{code}
......@@ -342,7 +324,6 @@ literalPrimRep (MachWord64 _) = Word64Rep
literalPrimRep (MachFloat _) = FloatRep
literalPrimRep (MachDouble _) = DoubleRep
literalPrimRep (MachLabel _ _) = AddrRep
literalPrimRep (MachLitLit _ ty) = typePrimRep ty
\end{code}
......@@ -359,7 +340,6 @@ cmpLit (MachWord64 a) (MachWord64 b) = a `compare` b
cmpLit (MachFloat a) (MachFloat b) = a `compare` b
cmpLit (MachDouble a) (MachDouble b) = a `compare` b
cmpLit (MachLabel a _) (MachLabel b _) = a `compare` b
cmpLit (MachLitLit a b) (MachLitLit c d) = (a `compare` c) `thenCmp` (b `tcCmpType` d)
cmpLit lit1 lit2 | litTag lit1 <# litTag lit2 = LT
| otherwise = GT
......@@ -373,7 +353,6 @@ litTag (MachWord64 _) = _ILIT(7)
litTag (MachFloat _) = _ILIT(8)
litTag (MachDouble _) = _ILIT(9)
litTag (MachLabel _ _) = _ILIT(10)
litTag (MachLitLit _ _) = _ILIT(11)
\end{code}
Printing
......@@ -426,11 +405,6 @@ pprLit lit
Nothing -> pprHsString l
Just x -> doubleQuotes (text (unpackFS l ++ '@':show x))
MachLitLit s ty | code_style -> ftext s
| otherwise -> parens (hsep [ptext SLIT("__litlit"),
pprHsString s,
pprParendType ty])
-- negative floating literals in code style need parentheses to avoid
-- interacting with surrounding syntax.
code_rational d | d < 0 = parens (rational d)
......@@ -476,7 +450,6 @@ hashLiteral (MachWord64 i) = hashInteger i
hashLiteral (MachFloat r) = hashRational r
hashLiteral (MachDouble r) = hashRational r
hashLiteral (MachLabel s _) = hashFS s
hashLiteral (MachLitLit s _) = hashFS s
hashRational :: Rational -> Int
hashRational r = hashInteger (numerator r)
......
......@@ -68,7 +68,7 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> [StgArg] -- Args
-> FCode (Id, CgIdInfo)
cgTopRhsCon id con args
= ASSERT( not (isDllConApp con args) ) -- checks for litlit args too
= ASSERT( not (isDllConApp con args) )
ASSERT( args `lengthIs` dataConRepArity con )
-- LAY IT OUT
......
......@@ -24,7 +24,6 @@ module CoreUnfold (
couldBeSmallEnoughToInline,
certainlyWillInline,
okToUnfoldInHiFile,
callSiteInline
) where
......@@ -35,7 +34,7 @@ import CmdLineOpts ( opt_UF_CreationThreshold,
opt_UF_UseThreshold,
opt_UF_FunAppDiscount,
opt_UF_KeenessFactor,
opt_UF_DearOp, opt_UnfoldCasms,
opt_UF_DearOp,
DynFlags, DynFlag(..), dopt
)
import CoreSyn
......@@ -47,9 +46,8 @@ import Id ( Id, idType, isId,
isFCallId_maybe, globalIdDetails
)
import DataCon ( isUnboxedTupleCon )
import Literal ( isLitLitLit, litSize )
import Literal ( litSize )
import PrimOp ( primOpIsDupable, primOpOutOfLine )
import ForeignCall ( okToExposeFCall )
import IdInfo ( OccInfo(..), GlobalIdDetails(..) )
import Type ( isUnLiftedType )
import PrelNames ( hasKey, buildIdKey, augmentIdKey )
......@@ -467,36 +465,6 @@ certainlyWillInline other
= False
\end{code}
@okToUnfoldInHifile@ is used when emitting unfolding info into an interface
file to determine whether an unfolding candidate really should be unfolded.
The predicate is needed to prevent @_casm_@s (+ lit-lits) from being emitted
into interface files.
The reason for inlining expressions containing _casm_s into interface files
is that these fragments of C are likely to mention functions/#defines that
will be out-of-scope when inlined into another module. This is not an
unfixable problem for the user (just need to -#include the approp. header
file), but turning it off seems to the simplest thing to do.
\begin{code}
okToUnfoldInHiFile :: CoreExpr -> Bool
okToUnfoldInHiFile e = opt_UnfoldCasms || go e
where
-- Race over an expression looking for CCalls..
go (Var v) = case isFCallId_maybe v of
Just fcall -> okToExposeFCall fcall
Nothing -> True
go (Lit lit) = not (isLitLitLit lit)
go (App fun arg) = go fun && go arg
go (Lam _ body) = go body
go (Let binds body) = and (map go (body :rhssOfBind binds))
go (Case scrut bndr alts) = and (map go (scrut:rhssOfAlts alts)) &&
not (any isLitLitLit [ lit | (LitAlt lit, _, _) <- alts ])
go (Note _ body) = go body
go (Type _) = True
\end{code}
%************************************************************************
%* *
\subsection{callSiteInline}
......
......@@ -45,7 +45,7 @@ import Var ( Var, isId, isTyVar )
import VarEnv
import Name ( hashName, isDllName )
import Literal ( hashLiteral, literalType, litIsDupable,
litIsTrivial, isZeroLit, isLitLitLit )
litIsTrivial, isZeroLit )
import DataCon ( DataCon, dataConRepArity, dataConArgTys,
isExistentialDataCon, dataConTyCon, dataConName )
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
......@@ -1157,11 +1157,10 @@ hashId id = hashName (idName id)
%* *
%************************************************************************
Top-level constructor applications can usually be allocated
statically, but they can't if
a) the constructor, or any of the arguments, come from another DLL
b) any of the arguments are LitLits
(because we can't refer to static labels in other DLLs).
Top-level constructor applications can usually be allocated
statically, but they can't if the constructor, or any of the
arguments, come from another DLL (because we can't refer to static
labels in other DLLs).
If this happens we simply make the RHS into an updatable thunk,
and 'exectute' it rather than allocating it statically.
......@@ -1235,10 +1234,7 @@ is_static False (Lam b e) = isRuntimeVar b || is_static False e
is_static in_arg (Note (SCC _) e) = False
is_static in_arg (Note _ e) = is_static in_arg e
is_static in_arg (Lit lit) = not (isLitLitLit lit)
-- lit-lit arguments cannot be used in static constructors either.
-- (litlits are deprecated, so I'm not going to bother cleaning up this infelicity --SDM).
is_static in_arg (Lit lit) = True
is_static in_arg other_expr = go other_expr 0
where
......
%
% (c) The AQUA Project, Glasgow University, 1994-1998
%
\section[DsCCall]{Desugaring \tr{_ccall_}s and \tr{_casm_}s}
\section[DsCCall]{Desugaring C calls}
\begin{code}
module DsCCall
......@@ -103,17 +103,15 @@ follows:
dsCCall :: CLabelString -- C routine to invoke
-> [CoreExpr] -- Arguments (desugared)
-> Safety -- Safety of the call
-> Bool -- True <=> really a "_casm_"
-> Type -- Type of the result: IO t
-> DsM CoreExpr
dsCCall lbl args may_gc is_asm result_ty
dsCCall lbl args may_gc result_ty
= mapAndUnzipDs unboxArg args `thenDs` \ (unboxed_args, arg_wrappers) ->
boxResult [] id Nothing result_ty `thenDs` \ (ccall_result_ty, res_wrapper) ->
getUniqueDs `thenDs` \ uniq ->
let
target | is_asm = CasmTarget lbl
| otherwise = StaticTarget lbl
target = StaticTarget lbl
the_fcall = CCall (CCallSpec target CCallConv may_gc)
the_prim_app = mkFCall uniq the_fcall unboxed_args ccall_result_ty
in
......
......@@ -236,11 +236,6 @@ dsExpr (SectionR op expr)
returnDs (bindNonRec y_id y_core $
Lam x_id (mkApps core_op [Var x_id, Var y_id]))
dsExpr (HsCCall lbl args may_gc is_asm result_ty)
= mapDs dsExpr args `thenDs` \ core_args ->
dsCCall lbl core_args may_gc is_asm result_ty
-- dsCCall does all the unboxification, etc.
dsExpr (HsSCC cc expr)
= dsExpr expr `thenDs` \ core_expr ->
getModuleDs `thenDs` \ mod_name ->
......
......@@ -391,7 +391,7 @@ dsFExportDynamic id cconv
StdCallConv -> Just sz_args
_ -> Nothing
in
dsCCall adjustor adj_args PlayRisky False io_res_ty `thenDs` \ ccall_adj ->
dsCCall adjustor adj_args PlayRisky io_res_ty `thenDs` \ ccall_adj ->
-- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
let ccall_adj_ty = exprType ccall_adj
ccall_io_adj = mkLams [stbl_value] $
......
......@@ -525,7 +525,6 @@ repE (ArithSeqIn aseq) =
repFromThenTo ds1 ds2 ds3
repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing"
repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations
repE (HsCCall _ _ _ _ _) = panic "DsMeta.repE: Can't represent __ccall__"
repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC"
repE (HsBracketOut _ _) =
panic "DsMeta.repE: Can't represent Oxford brackets"
......
......@@ -12,7 +12,6 @@ import {-# SOURCE #-} Match ( match )
import {-# SOURCE #-} DsExpr ( dsExpr )
import DsMonad
import DsCCall ( resultWrapper )
import DsUtils
import HsSyn ( HsLit(..), Pat(..), HsExpr(..) )
......@@ -26,9 +25,7 @@ import PrelNames ( ratioTyConKey )
import Unique ( hasKey )
import Literal ( mkMachInt, Literal(..) )
import Maybes ( catMaybes )
import Type ( isUnLiftedType )
import Panic ( panic, assertPanic )
import Maybe ( isJust )
import Ratio ( numerator, denominator )
\end{code}
......@@ -64,11 +61,6 @@ dsLit (HsInt i) = returnDs (mkIntExpr i)
dsLit (HsIntPrim i) = returnDs (mkIntLit i)
dsLit (HsFloatPrim f) = returnDs (mkLit (MachFloat f))
dsLit (HsDoublePrim d) = returnDs (mkLit (MachDouble d))
dsLit (HsLitLit str ty)
= resultWrapper ty `thenDs` \ (maybe_ty, wrap_fn) ->
ASSERT( isJust maybe_ty )
let (Just rep_ty) = maybe_ty in
returnDs (wrap_fn (mkLit (MachLitLit str rep_ty)))
dsLit (HsRat r ty)
= mkIntegerExpr (numerator r) `thenDs` \ num ->
......@@ -133,8 +125,6 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal : ps1
mk_core_lit (HsStringPrim s) = MachStr s
mk_core_lit (HsFloatPrim f) = MachFloat f
mk_core_lit (HsDoublePrim d) = MachDouble d
mk_core_lit (HsLitLit s ty) = ASSERT(isUnLiftedType ty)
MachLitLit s ty
mk_core_lit other = panic "matchLiterals:mk_core_lit:unhandled"
\end{code}
......
......@@ -39,7 +39,7 @@ import RdrName ( RdrName, rdrNameOcc )
import CoreSyn
import CostCentre ( pprCostCentreCore )
import NewDemand ( StrictSig, pprIfaceStrictSig )
import Literal ( Literal, maybeLitLit )
import Literal ( Literal )
import ForeignCall ( ForeignCall )
import DataCon ( dataConTyCon, dataConSourceArity )
import TyCon ( isTupleTyCon, tupleTyConBoxity )
......@@ -69,7 +69,6 @@ data UfExpr name
| UfLet (UfBinding name) (UfExpr name)
| UfNote (UfNote name) (UfExpr name)
| UfLit Literal
| UfLitLit FastString (HsType name)
| UfFCall ForeignCall (HsType name)
data UfNote name = UfSCC CostCentre
......@@ -84,7 +83,6 @@ data UfConAlt name = UfDefault
| UfDataAlt name
| UfTupleAlt HsTupCon
| UfLitAlt Literal
| UfLitLitAlt FastString (HsType name)
data UfBinding name
= UfNonRec (UfBinder name)
......@@ -110,9 +108,7 @@ ufBinderName (UfTyBinder n _) = n
\begin{code}
toUfExpr :: CoreExpr -> UfExpr Name
toUfExpr (Var v) = toUfVar v
toUfExpr (Lit l) = case maybeLitLit l of
Just (s,ty) -> UfLitLit s (toHsType ty)
Nothing -> UfLit l
toUfExpr (Lit l) = UfLit l
toUfExpr (Type ty) = UfType (toHsType ty)
toUfExpr (Lam x b) = UfLam (toUfBndr x) (toUfExpr b)
toUfExpr (App f a) = toUfApp f [a]
......@@ -140,9 +136,7 @@ toUfCon (DataAlt dc) | isTupleTyCon tc = UfTupleAlt (mk_hs_tup_con tc dc)
where
tc = dataConTyCon dc
toUfCon (LitAlt l) = case maybeLitLit l of
Just (s,ty) -> UfLitLitAlt s (toHsType ty)
Nothing -> UfLitAlt l
toUfCon (LitAlt l) = UfLitAlt l
toUfCon DEFAULT = UfDefault
---------------------
......@@ -207,7 +201,6 @@ pprUfExpr :: OutputableBndr name => (SDoc -> SDoc) -> UfExpr name -> SDoc
pprUfExpr add_par (UfVar v) = ppr v
pprUfExpr add_par (UfLit l) = ppr l
pprUfExpr add_par (UfLitLit l ty) = add_par (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
pprUfExpr add_par (UfFCall cc ty) = braces (ppr cc <+> ppr ty)
pprUfExpr add_par (UfType ty) = char '@' <+> pprParendHsType ty
......@@ -259,7 +252,6 @@ instance Outputable name => Outputable (UfNote name) where
instance Outputable name => Outputable (UfConAlt name) where
ppr UfDefault = text "__DEFAULT"
ppr (UfLitAlt l) = ppr l
ppr (UfLitLitAlt l ty) = parens (hsep [ptext SLIT("__litlit"), pprHsString l, pprParendHsType ty])
ppr (UfDataAlt d) = ppr d
instance Outputable name => Outputable (UfBinder name) where
......@@ -326,7 +318,6 @@ eq_ufVar env n1 n2 = case lookupFM env n1 of
eq_ufExpr :: (NamedThing name, Ord name) => EqHsEnv name -> UfExpr name -> UfExpr name -> Bool
eq_ufExpr env (UfVar v1) (UfVar v2) = eq_ufVar env v1 v2
eq_ufExpr env (UfLit l1) (UfLit l2) = l1 == l2
eq_ufExpr env (UfLitLit l1 ty1) (UfLitLit l2 ty2) = l1==l2 && eq_hsType env ty1 ty2
eq_ufExpr env (UfFCall c1 ty1) (UfFCall c2 ty2) = c1==c2 && eq_hsType env ty1 ty2
eq_ufExpr env (UfType ty1) (UfType ty2) = eq_hsType env ty1 ty2
eq_ufExpr env (UfTuple n1 as1) (UfTuple n2 as2) = n1==n2 && eqListBy (eq_ufExpr env) as1 as2
......@@ -366,7 +357,6 @@ eq_ufConAlt env UfDefault UfDefault = True
eq_ufConAlt env (UfDataAlt n1) (UfDataAlt n2) = n1==n2
eq_ufConAlt env (UfTupleAlt c1) (UfTupleAlt c2) = c1==c2
eq_ufConAlt env (UfLitAlt l1) (UfLitAlt l2) = l1==l2
eq_ufConAlt env (UfLitLitAlt s1 t1) (UfLitLitAlt s2 t2) = s1==s2 && eq_hsType env t1 t2
eq_ufConAlt env _ _ = False
\end{code}
......
......@@ -794,8 +794,6 @@ instance Outputable ForeignImport where
pprLib lib <> ppr lbl
pprCEntity header lib (CFunction (DynamicTarget)) =
ptext SLIT("dynamic")
pprCEntity header lib (CFunction (CasmTarget _)) =
panic "HsDecls.pprCEntity: malformed C function target"
pprCEntity _ _ (CWrapper) = ptext SLIT("wrapper")
--
pprLib lib | nullFastString lib = empty
......
......@@ -17,14 +17,11 @@ import HsTypes ( HsType, PostTcType, SyntaxName )
import HsImpExp ( isOperator, pprHsVar )
-- others:
import ForeignCall ( Safety )
import PprType ( pprParendType )
import Type ( Type )
import Var ( TyVar, Id )
import Name ( Name )
import NameSet ( FreeVars )
import DataCon ( DataCon )
import CStrings ( CLabelString, pprCLabelString )
import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) )
import SrcLoc ( SrcLoc )
import Outputable
......@@ -141,19 +138,6 @@ data HsExpr id
(HsExpr id) -- (typechecked, of course)
(ArithSeqInfo id)
| HsCCall CLabelString -- call into the C world; string is
[HsExpr id] -- the C function; exprs are the
-- arguments to pass.
Safety -- True <=> might cause Haskell
-- garbage-collection (must generate
-- more paranoid code)
Bool -- True <=> it's really a "casm"
-- NOTE: this CCall is the *boxed*
-- version; the desugarer will convert
-- it into the unboxed "ccall#".
PostTcType -- The result type; will be *bottom*
-- until the typechecker gets ahold of it
| HsSCC FastString -- "set cost centre" (_scc_) annotation
(HsExpr id) -- expr whose cost is to be measured
......@@ -390,12 +374,6 @@ ppr_expr EWildPat = char '_'
ppr_expr (ELazyPat e) = char '~' <> pprParendExpr e
ppr_expr (EAsPat v e) = ppr v <> char '@' <> pprParendExpr e
ppr_expr (HsCCall fun args _ is_asm result_ty)
= hang (if is_asm
then ptext SLIT("_casm_ ``") <> pprCLabelString fun <> ptext SLIT("''")
else ptext SLIT("_ccall_") <+> pprCLabelString fun)
4 (sep (map pprParendExpr args))
ppr_expr (HsSCC lbl expr)
= sep [ ptext SLIT("_scc_") <+> doubleQuotes (ftext lbl), pprParendExpr expr ]
......
......@@ -38,11 +38,6 @@ data HsLit
-- (overloaded literals are done with HsOverLit)
| HsFloatPrim Rational -- Unboxed Float
| HsDoublePrim Rational -- Unboxed Double
| HsLitLit FastString PostTcType -- to pass ``literal literals'' through to C
-- also: "overloaded" type; but
-- must resolve to boxed-primitive!
-- The Type in HsLitLit is needed when desuaring;
-- before the typechecker it's just an error value
instance Eq HsLit where
(HsChar x1) == (HsChar x2) = x1==x2
......@@ -55,7 +50,6 @@ instance Eq HsLit where
(HsRat x1 _) == (HsRat x2 _) = x1==x2
(HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2
(HsDoublePrim x1) == (HsDoublePrim x2) = x1==x2
(HsLitLit x1 _) == (HsLitLit x2 _) = x1==x2
lit1 == lit2 = False
data HsOverLit -- An overloaded literal
......@@ -88,11 +82,8 @@ instance Outputable HsLit where
ppr (HsFloatPrim f) = rational f <> char '#'
ppr (HsDoublePrim d) = rational d <> text "##"
ppr (HsIntPrim i) = integer i <> char '#'
ppr (HsLitLit s _) = hcat [text "``", ftext s, text "''"]
instance Outputable HsOverLit where
ppr (HsIntegral i _) = integer i
ppr (HsFractional f _) = rational f
\end{code}
......@@ -788,12 +788,8 @@ instance (Binary name) => Binary (UfExpr name) where
put_ bh (UfLit ap) = do
putByte bh 8
put_ bh ap
put_ bh (UfLitLit aq ar) = do
putByte bh 9
put_ bh aq
put_ bh ar
put_ bh (UfFCall as at) = do
putByte bh 10
putByte bh 9
put_ bh as
put_ bh at
get bh = do
......@@ -824,9 +820,6 @@ instance (Binary name) => Binary (UfExpr name) where
return (UfNote an ao)
8 -> do ap <- get bh
return (UfLit ap)
9 -> do aq <- get bh
ar <- get bh
return (UfLitLit aq ar)
_ -> do as <- get bh
at <- get bh
return (UfFCall as at)
......@@ -843,10 +836,6 @@ instance (Binary name) => Binary (UfConAlt name) where
put_ bh (UfLitAlt ac) = do
putByte bh 3
put_ bh ac
put_ bh (UfLitLitAlt ad ae) = do
putByte bh 4
put_ bh ad
put_ bh ae
get bh = do
h <- getByte bh
case h of
......@@ -855,11 +844,8 @@ instance (Binary name) => Binary (UfConAlt name) where
return (UfDataAlt aa)
2 -> do ab <- get bh
return (UfTupleAlt ab)
3 -> do ac <- get bh
_ -> do ac <- get bh
return (UfLitAlt ac)
_ -> do ad <- get bh
ae <- get bh
return (UfLitLitAlt ad ae)
instance (Binary name) => Binary (UfBinding name) where
put_ bh (UfNonRec aa ab) = do
......
......@@ -75,7 +75,6 @@ module CmdLineOpts (
opt_DoSemiTagging,
opt_LiberateCaseThreshold,
opt_StgDoLetNoEscapes,
opt_UnfoldCasms,
opt_CprOff,
opt_RulesOff,
opt_UnboxStrictFields,
......@@ -592,7 +591,6 @@ opt_RulesOff = lookUp FSLIT("-frules-off")
-- Switch off CPR analysis in the new demand analyser
opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int)
opt_StgDoLetNoEscapes = lookUp FSLIT("-flet-no-escape")
opt_UnfoldCasms = lookUp FSLIT("-funfold-casms-in-hi-file")
opt_UnboxStrictFields = lookUp FSLIT("-funbox-strict-fields")
opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int)
......@@ -666,7 +664,6 @@ isStaticHscFlag f =
"fflatten",
"fsemi-tagging",
"flet-no-escape",
"funfold-casms-in-hi-file",
"funbox-strict-fields",
"femit-extern-decls",
"fglobalise-toplev-names",
......
......@@ -10,7 +10,7 @@ module TidyPgm( tidyCorePgm, tidyCoreExpr ) where
import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
import CoreUnfold ( noUnfolding, mkTopUnfolding )
import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars )
import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules )
import PprCore ( pprIdRules )
......@@ -374,8 +374,7 @@ addExternal (id,rhs) needed
show_unfold = not bottoming_fn && -- Not necessary
not dont_inline &&
not loop_breaker &&
rhs_is_small && -- Small enough
okToUnfoldInHiFile rhs -- No casms etc
rhs_is_small -- Small enough
unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
| otherwise = emptyVarSet
......
......@@ -50,14 +50,11 @@ foreignCallCode
%* *
%************************************************************************
First, the dreaded @ccall@. We can't handle @casm@s.
First, the dreaded @ccall@.
Usually, this compiles to an assignment, but when the left-hand side
is empty, we just perform the call and ignore the result.
btw Why not let programmer use casm to provide assembly code instead
of C code? ADR
ToDo: saving/restoring of volatile regs around ccalls.
JRS, 001113: always do the call of suspendThread and resumeThread as a ccall
......@@ -96,9 +93,6 @@ foreignCallCode lhs call@(CCall (CCallSpec ctarget cconv safety)) rhs
StaticTarget nm -> (rhs, Left nm)
DynamicTarget | notNull rhs -- an assertion
-> (tail rhs, Right (amodeToStix (head rhs)))
CasmTarget _
-> ncgPrimopMoan "Native code generator can't handle foreign call"
(ppr call)
stix_args = map amodeToStix' cargs
......@@ -187,7 +181,6 @@ amodeToStix (CLit core)
MachNullAddr -> StInt 0
MachInt i -> StInt i
MachWord w -> case word2IntLit core of MachInt iw -> StInt iw
MachLitLit s _ -> litLitErr
-- dreadful, but rare.
MachLabel l (Just x) -> StCLbl (mkForeignLabel (mkFastString (unpackFS l ++ '@':show x)) False)
MachLabel l _ -> StCLbl (mkForeignLabel l False{-ToDo: dynamic-})
......@@ -221,9 +214,6 @@ amodeToStix (CMacroExpr _ macro [arg])
amodeToStix other
= pprPanic "StixPrim.amodeToStix" (pprAmode other)
litLitErr
= ncgPrimopMoan "native code generator can't handle lit-lits" empty
\end{code}