-- it's ok to convert one of the alts into a default if we don't already have
-- one, because this is an algebraic case and we're guaranteed that the tag
-- will match one of the branches.
- ((tag,first_alt):rest) = tagged_alts
+ ((_,first_alt):rest) = tagged_alts
-- Adjust the tags in the switch to start at zero.
-- This is the convention used by primitive ops which return algebraic
-- True of Ids that are locally defined, but are not constants
-- like data constructors, record selectors, and the like.
-- See comments with CoreFVs.isLocalVar
-isLocalId id = case idFlavour id of
- VanillaId -> True
- ExportedId -> True
- SpecPragmaId -> True
- other -> False
+isLocalId id
+#ifdef DEBUG
+ | not (isId id) = pprTrace "isLocalid" (ppr id) False
+ | otherwise
+#endif
+ = case idFlavour id of
+ VanillaId -> True
+ ExportedId -> True
+ SpecPragmaId -> True
+ other -> False
\end{code}
import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import CLabel ( mkConEntryLabel )
import ClosureInfo ( layOutStaticClosure, layOutDynCon,
mkConLFInfo, ClosureInfo
)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.39 2000/11/15 17:07:34 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.40 2000/11/24 09:51:38 simonpj Exp $
%
%********************************************************
%* *
import CostCentre ( sccAbleCostCentre, isSccCountCostCentre )
import Id ( idPrimRep, idType, Id )
import VarSet
-import DataCon ( dataConTyCon )
import PrimOp ( primOpOutOfLine, getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..) )
import PrimRep ( PrimRep(..), isFollowableRep )
import TyCon ( maybeTyConSingleCon,
isUnboxedTupleTyCon, isEnumerationTyCon )
-import Type ( Type, typePrimRep, splitTyConApp, tyConAppTyCon, repType )
+import Type ( Type, typePrimRep, tyConAppArgs, tyConAppTyCon, repType )
import Maybes ( maybeToBool )
import ListSetOps ( assocMaybe )
import Unique ( mkBuiltinUnique )
allocate some temporaries for the return values.
-}
let
- (tc,ty_args) = splitTyConApp (repType res_ty)
- prim_reps = map typePrimRep ty_args
- temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
- temp_amodes = zipWith CTemp temp_uniqs prim_reps
+ ty_args = tyConAppArgs (repType res_ty)
+ prim_reps = map typePrimRep ty_args
+ temp_uniqs = map mkBuiltinUnique [ n_args .. n_args + length ty_args - 1]
+ temp_amodes = zipWith CTemp temp_uniqs prim_reps
in
returnUnboxedTuple temp_amodes (absC (COpStmt temp_amodes op arg_temps []))
\end{code}
import GetImports
import HscTypes ( HomeSymbolTable, HomeIfaceTable,
PersistentCompilerState, ModDetails(..) )
-import Type ( Type )
import Name ( lookupNameEnv )
import Module
import PrelNames ( mainName )
import Interpreter ( HValue )
import HscMain ( hscExpr, hscTypeExpr )
import RdrName
+import Type ( Type )
import PrelGHC ( unsafeCoerce# )
#endif
mkForeignExportOcc, isLocalName,
NamedThing(..),
)
-import Type ( repType,
- splitTyConApp_maybe, tyConAppTyCon, splitFunTys, splitForAllTys,
+import Type ( splitTyConApp_maybe, tyConAppTyCon, splitFunTys, splitForAllTys,
Type, mkFunTys, mkForAllTys, mkTyConApp,
mkFunTy, splitAppTy, applyTy, funResultTy
)
in
newSysLocalDs zipTy `thenDs` \ zipFn ->
let target = mkConsExpr retTy (mkTupleExpr as) (foldl App (Var zipFn) (map Var as's))
- zipExp = mkLet zipFn (zip4 (map fst bndrstmtss) ass as as's) exps target
+ zipExp = mkLet zipFn (zip4 bndrss ass as as's) exps target
in
deBindComp pat zipExp quals list
where (bndrss, stmtss) = unzip bndrstmtss
import TyCon ( TyCon )
import Id ( Id )
import CoreSyn ( CoreBind )
+import OccurAnal ( occurAnalyseBinds )
import StgSyn ( StgBinding )
import AbsCSyn ( AbstractC )
import PprAbsC ( dumpRealC, writeRealC )
= doOutput filenm (\ f -> printForUser f alwaysQualify pp_java)
-- User style printing for now to keep indentation
where
- java_code = javaGen mod [{- Should be imports-}] tycons core_binds
+ occ_anal_binds = occurAnalyseBinds core_binds
+ -- Make sure we have up to date dead-var information
+ java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds
pp_java = PrintJava.compilationUnit java_code
\end{code}
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.23 2000/11/22 12:19:29 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.24 2000/11/24 09:51:39 simonpj Exp $
--
-- Driver flags
--
import CmdLineOpts
import Config
import Util
-
+import TmpFiles ( newTempName )
+import Directory ( removeFile )
import Exception
import IOExts
import IO
dcl_rules = sortLt lt_rule rules,
dcl_insts = insts }
where
- d1 `lt_tycl` d2 = nameOccName (tyClDeclName d1) < nameOccName (tyClDeclName d2)
- r1 `lt_rule` r2 = nameOccName (ifaceRuleDeclName r1) < nameOccName (ifaceRuleDeclName r2)
-
- -- I wanted to sort just by the Name, but there's a problem: we are comparing
- -- the old version of an interface with the new version. The latter will use
- -- local names like 'lvl23' that were constructed not by the renamer but by
- -- the simplifier. So the unqiues aren't going to line up.
- --
- -- It's ok to compare by OccName because this comparison only drives the
- -- computation of new version numbers.
- --
- -- Better solutions: Compare in a way that is insensitive to the name used
- -- for local things. This would decrease the wobbles due
- -- to 'lvl23' changing to 'lvl24'.
- --
- -- NB: there's a related comparision on MkIface.diffDecls!
-
-
+ d1 `lt_tycl` d2 = tyClDeclName d1 < tyClDeclName d2
+ r1 `lt_rule` r2 = ifaceRuleDeclName r1 < ifaceRuleDeclName r2
-- typechecker should only look at this, not ModIface
{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.32 2000/11/22 17:51:16 simonmar Exp $
+-- $Id: Main.hs,v 1.33 2000/11/24 09:51:39 simonpj Exp $
--
-- GHC Driver program
--
#include "HsVersions.h"
-import CompManager
-import Interpreter
+
#ifdef GHCI
+import Interpreter
import InteractiveUI
+import Dynamic
#endif
+
+import CompManager
import DriverPipeline
import DriverState
import DriverFlags
import Panic
import DriverPhases ( Phase(..) )
import CmdLineOpts ( HscLang(..), DynFlags(..), v_Static_hsc_opts )
-import Module ( mkModuleName )
import TmpFiles
import Finder ( initFinder )
import CmStaticInfo
import Config
import Util
+
+
import Concurrent
#ifndef mingw32_TARGET_OS
import Posix
import Directory
import IOExts
import Exception
-import Dynamic
import IO
import Monad
snocOL, consOL, concatOL )
import AbsCUtils ( magicIdPrimRep )
import CallConv ( CallConv )
-import CLabel ( isAsmTemp, CLabel, pprCLabel_asm, labelDynamic )
+import CLabel ( isAsmTemp, CLabel, labelDynamic )
import Maybes ( maybeToBool, expectJust )
import PrimRep ( isFloatingRep, PrimRep(..) )
import PrimOp ( PrimOp(..) )
import Stix ( getNatLabelNCG, StixTree(..),
StixReg(..), CodeSegment(..),
DestInfo, hasDestInfo,
- pprStixTree, ppStixReg,
+ pprStixTree,
NatM, thenNat, returnNat, mapNat,
mapAndUnzipNat, mapAccumLNat,
getDeltaNat, setDeltaNat
let
code = condCode condition
cond = condName condition
- target = ImmCLbl lbl
in
returnNat (code `snocOL` JXX cond lbl)
)
import Module ( Module, ModuleName, WhereFrom(..),
moduleNameUserString, moduleName,
- moduleEnvElts, lookupModuleEnv
+ moduleEnvElts
)
import Name ( Name, NamedThing(..), getSrcLoc,
nameIsLocalOrFrom, nameOccName, nameModule,
\begin{code}
type VertexTag = Int
-type Cycle = [VertexTag]
-type Edge = (VertexTag, VertexTag)
\end{code}
%************************************************************************
rnStmt rn_expr (ParStmt stmtss) thing_inside
= mapFvRn (rnStmts rn_expr) stmtss `thenRn` \ (bndrstmtss, fv_stmtss) ->
- let (binderss, stmtss') = unzip bndrstmtss
+ let binderss = map fst bndrstmtss
checkBndrs all_bndrs bndrs
= checkRn (null (intersectBy eqOcc all_bndrs bndrs)) err `thenRn_`
returnRn (bndrs ++ all_bndrs)
\begin{code}
-getSlurped
- = getIfacesRn `thenRn` \ ifaces ->
- returnRn (iSlurp ifaces)
-
recordSlurp ifaces@(Ifaces { iDecls = (decls_map, n_slurped),
iSlurp = slurped_names,
iVSlurp = (imp_mods, imp_names) })
unqual_imp = True -- Want unqualified names
mk_prov n = LocalDef -- Provenance is local
hides = [] -- Hide nothing
- gbl_env = mkGlobalRdrEnv mod_name unqual_imp [] mk_prov avails
- exports = mkExportAvails mod_name unqual_imp gbl_env avails
+ gbl_env = mkGlobalRdrEnv mod_name unqual_imp hides mk_prov avails
+ exports = mkExportAvails mod_name unqual_imp gbl_env avails
in
returnRn (gbl_env, exports)
\begin{code}
type LevelledExpr = TaggedExpr Level
-type LevelledArg = TaggedArg Level
type LevelledBind = TaggedBind Level
tOP_LEVEL = Level 0 0
; us <- mkSplitUniqSupply 's'
- ; let (expr', counts) = initSmpl dflags sw_chkr us emptyVarSet black_list_all
- (simplExpr expr)
+ ; let (expr', _counts) = initSmpl dflags sw_chkr us emptyVarSet black_list_all
+ (simplExpr expr)
; dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplfied expression"
(pprCoreExpr expr')
)
import Id ( Id )
import Module ( Module )
-import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn )
-import UniqSupply ( splitUniqSupply, UniqSupply )
+import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn, showPass )
+import UniqSupply ( mkSplitUniqSupply, splitUniqSupply, UniqSupply )
import IO ( hPutStr, stdout )
import Outputable
\end{code}
[CostCentreStack])) -- pre-defined "singleton" cost centre stacks
stg2stg dflags module_name us binds
- = case (splitUniqSupply us) of { (us4now, us4later) ->
+ = do { showPass dflags "Stg2Stg"
+ ; us <- mkSplitUniqSupply 'g'
- doIfSet_dyn dflags Opt_D_verbose_stg2stg (printDump (text "VERBOSE STG-TO-STG:")) >>
+ ; doIfSet_dyn dflags Opt_D_verbose_stg2stg
+ (printDump (text "VERBOSE STG-TO-STG:"))
- end_pass us4now "Core2Stg" ([],[],[]) binds
- >>= \ (binds', us, ccs) ->
+ ; (binds', us', ccs) <- end_pass us "Core2Stg" ([],[],[]) binds
- -- Do the main business!
- foldl_mn do_stg_pass (binds', us, ccs) (dopt_StgToDo dflags)
- >>= \ (processed_binds, _, cost_centres) ->
-
- -- Do essential wind-up
+ -- Do the main business!
+ ; (processed_binds, _, cost_centres)
+ <- foldl_mn do_stg_pass (binds', us', ccs)
+ (dopt_StgToDo dflags)
+ -- Do essential wind-up
-- Essential wind-up: part (b), do setStgVarInfo. It has to
-- happen regardless, because the code generator uses its
-- decorations.
-- correct, which is done by satStgRhs.
--
- let
- annotated_binds = setStgVarInfo opt_StgDoLetNoEscapes processed_binds
- srt_binds = computeSRTs annotated_binds
- in
+ ; let annotated_binds = setStgVarInfo opt_StgDoLetNoEscapes processed_binds
+ srt_binds = computeSRTs annotated_binds
- dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
- (pprStgBindingsWithSRTs srt_binds) >>
+ ; dumpIfSet_dyn dflags Opt_D_dump_stg "STG syntax:"
+ (pprStgBindingsWithSRTs srt_binds)
- return (srt_binds, cost_centres)
+ ; return (srt_binds, cost_centres)
}
where
import PrimOp ( PrimOp(..), ccallMayGC )
import TysWiredIn ( isForeignObjTy )
import Maybes ( maybeToBool, orElse )
-import Name ( isLocalName, getOccName )
+import Name ( getOccName )
import OccName ( occNameUserString )
import BasicTypes ( Arity )
import Outputable
\ body -> Case body work_wild [(DataAlt data_con, args, ubx_tup_app)],
ubx_tup_ty)
where
- (tycon, tycon_arg_tys, data_con, con_arg_tys) = splitProductType "mkWWcpr" body_ty
+ (_, tycon_arg_tys, data_con, con_arg_tys) = splitProductType "mkWWcpr" body_ty
n_con_args = length con_arg_tys
con_arg_ty1 = head con_arg_tys
\end{code}
InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy,
newDFunName, tcExtendTyVarEnv
)
-import InstEnv ( InstEnv, extendInstEnv, pprInstEnv )
+import InstEnv ( InstEnv, extendInstEnv )
import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType )
import TcSimplify ( tcSimplifyAndCheck )
import TcType ( zonkTcSigTyVars )
-> TcM (([TcStmt], [(Name, TcId)]), LIE)
tcStmts do_or_lc m elt_ty loc (ParStmtOut bndrstmtss : stmts)
- = let (bndrss, stmtss) = unzip bndrstmtss in
+ = let stmtss = map snd bndrstmtss in
mapAndUnzip3Tc (tcParStep loc) stmtss `thenTc` \ (stmtss', val_envs, lies) ->
let outstmts = zip (map (map snd) val_envs) stmtss'
lie = plusLIEs lies
\begin{code}
tyConDataCons :: TyCon -> [DataCon]
-tyConDataCons tycon = ASSERT2( not (null cons), ppr tycon ) cons
+tyConDataCons tycon = ASSERT2( not (null cons), ppr tycon )
+ ASSERT2( length cons == tyConFamilySize tycon, ppr tycon )
+ cons
where
cons = tyConDataConsIfAvailable tycon
import VarEnv
import VarSet
-import Name ( Name, tcName )
+import Name ( Name )
import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon )
import Class ( Class )
projects / ghc-hetmet.git / commitdiff