diff options
| author | simonpj <unknown> | 1997-03-17 20:35:30 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 1997-03-17 20:35:30 +0000 |
| commit | 2494407a750053daa61718fac371487d04818e57 (patch) | |
| tree | a90df45855ef4ccaa3c3d14b9066f485036f756c /ghc | |
| parent | 1fb1ab5d53a09607e7f6d2450806760688396387 (diff) | |
| download | haskell-2494407a750053daa61718fac371487d04818e57.tar.gz | |
[project @ 1997-03-17 20:34:25 by simonpj]
More small changes towards 2.02
Diffstat (limited to 'ghc')
30 files changed, 735 insertions, 505 deletions
diff --git a/ghc/Makefile b/ghc/Makefile index 3876e1b670..42b121c616 100644 --- a/ghc/Makefile +++ b/ghc/Makefile @@ -1,5 +1,5 @@ #----------------------------------------------------------------------------- -# $Id: Makefile,v 1.3 1997/03/14 07:53:55 simonpj Exp $ +# $Id: Makefile,v 1.4 1997/03/17 20:34:29 simonpj Exp $ # TOP=. @@ -49,7 +49,7 @@ boot :: $(line) @echo "Booting Prelude libraries" $(line) - @$(MAKE) -C compiler boot + @$(MAKE) -C lib boot # "CONTRIB" is also a SUBDIR, but there is nothing to build there. diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index b0b54d0a9b..972a8ca0ac 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: Makefile,v 1.8 1997/03/14 07:55:43 simonpj Exp $ +# $Id: Makefile,v 1.9 1997/03/17 20:34:30 simonpj Exp $ TOP = .. include $(TOP)/mk/boilerplate.mk @@ -226,6 +226,7 @@ all :: hsp hsp: parser/printtree.o parser/main.o libhsp.a $(CC) -o $@ $(CC_OPTS) $^ +CLEAN_FILES += hsp #----------------------------------------------------------------------------- # Interface files diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index be099d0b14..28cab79687 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -433,7 +433,7 @@ data MagicId -- Argument and return registers | VanillaReg -- pointers, unboxed ints and chars - PrimRep -- PtrRep, IntRep, CharRep, StablePtrRep or ForeignObjRep + PrimRep -- PtrRep, IntRep, CharRep, StablePtrRep or ForeignObjRep -- (in case we need to distinguish) FAST_INT -- its number (1 .. mAX_Vanilla_REG) diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index b2e60c492a..7fba22e30f 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -747,20 +747,22 @@ ppr_casm_results sty [r] liveness (result_type, assign_result) = case r_kind of -{- @ForeignObj@s replaces MallocPtrs and are *not* CReturnable. - Instead, external references have to be turned into ForeignObjs +{- + @ForeignObj@s replaces MallocPtrs and are *not* CReturnable. + Instead, external references have to explicitly turned into ForeignObjs using the primop makeForeignObj#. Benefit: Multiple finalisation routines can be accommodated and the below special case is not needed. Price is, of course, that you have to explicitly wrap `foreign objects' with makeForeignObj#. -+ + ForeignObjRep -> (uppPStr SLIT("StgForeignObj"), uppBesides [ uppPStr SLIT("constructForeignObj"),uppChar '(', liveness, uppComma, result_reg, uppComma, local_var, - pp_paren_semi ]) -} + pp_paren_semi ]) +-} _ -> (pprPrimKind sty r_kind, uppBesides [ result_reg, uppEquals, local_var, uppSemi ]) diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 5f14e9fed8..3dbdbcd887 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -195,6 +195,7 @@ module Unique ( stateTyConKey, synchVarPrimTyConKey, thenMClassOpKey, + toEnumClassOpKey, traceIdKey, trueDataConKey, unpackCString2IdKey, @@ -680,4 +681,5 @@ mainPrimIoKey = mkPreludeMiscIdUnique 67 returnMClassOpKey = mkPreludeMiscIdUnique 68 -- Used for minusClassOp 69 otherwiseIdKey = mkPreludeMiscIdUnique 70 +toEnumClassOpKey = mkPreludeMiscIdUnique 71 \end{code} diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 38e567a7ea..c2034d75e5 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -282,7 +282,7 @@ pprDsWarnings sty warns = ppCat [ppPStr SLIT("in the definition of function"), ppQuote (ppr sty fun)] pp_match CaseMatch pats - = ppHang (ppPStr SLIT("in a group of case alternative beginning:")) + = ppHang (ppPStr SLIT("in a group of case alternatives beginning:")) 4 (ppSep [ppSep (map (ppr sty) pats), pp_arrow_dotdotdot]) pp_match PatBindMatch pats diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 98364f2573..426eb62e1b 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -15,7 +15,7 @@ module PrelInfo ( eq_RDR, ne_RDR, le_RDR, lt_RDR, ge_RDR, gt_RDR, max_RDR, min_RDR, compare_RDR, minBound_RDR, maxBound_RDR, enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, - enumFromThenTo_RDR, fromEnum_RDR, + enumFromThenTo_RDR, fromEnum_RDR, toEnum_RDR, range_RDR, index_RDR, inRange_RDR, readsPrec_RDR, readList_RDR, showsPrec_RDR, showList_RDR, plus_RDR, times_RDR, ltTag_RDR, eqTag_RDR, gtTag_RDR, eqH_Char_RDR, ltH_Char_RDR, eqH_Word_RDR, ltH_Word_RDR, eqH_Addr_RDR, ltH_Addr_RDR, @@ -299,6 +299,7 @@ knownKeyNames , (enumFromTo_RDR, enumFromToClassOpKey) , (enumFromThenTo_RDR, enumFromThenToClassOpKey) , (fromEnum_RDR, fromEnumClassOpKey) + , (toEnum_RDR, toEnumClassOpKey) , (eq_RDR, eqClassOpKey) , (thenM_RDR, thenMClassOpKey) , (returnM_RDR, returnMClassOpKey) @@ -361,6 +362,7 @@ creturnableClass_RDR = tcQual (fOREIGN, SLIT("CReturnable")) fromInt_RDR = varQual (pREL_BASE, SLIT("fromInt")) fromInteger_RDR = varQual (pREL_BASE, SLIT("fromInteger")) minus_RDR = varQual (pREL_BASE, SLIT("-")) +toEnum_RDR = varQual (pREL_BASE, SLIT("toEnum")) fromEnum_RDR = varQual (pREL_BASE, SLIT("fromEnum")) enumFrom_RDR = varQual (pREL_BASE, SLIT("enumFrom")) enumFromTo_RDR = varQual (pREL_BASE, SLIT("enumFromTo")) diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index bd24ebe37d..7ba7dd392b 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -154,7 +154,8 @@ data PrimOp | TakeMVarOp | PutMVarOp | ReadIVarOp | WriteIVarOp - | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL) + | MakeForeignObjOp -- foreign objects (malloc pointers or any old URL) + | WriteForeignObjOp -- modifying foreign objects [obscuro factor: 200] | MakeStablePtrOp | DeRefStablePtrOp \end{code} @@ -413,26 +414,27 @@ tagOf_PrimOp PutMVarOp = ILIT(152) tagOf_PrimOp ReadIVarOp = ILIT(153) tagOf_PrimOp WriteIVarOp = ILIT(154) tagOf_PrimOp MakeForeignObjOp = ILIT(155) -tagOf_PrimOp MakeStablePtrOp = ILIT(156) -tagOf_PrimOp DeRefStablePtrOp = ILIT(157) -tagOf_PrimOp (CCallOp _ _ _ _ _) = ILIT(158) -tagOf_PrimOp ErrorIOPrimOp = ILIT(159) -tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(160) -tagOf_PrimOp SeqOp = ILIT(161) -tagOf_PrimOp ParOp = ILIT(162) -tagOf_PrimOp ForkOp = ILIT(163) -tagOf_PrimOp DelayOp = ILIT(164) -tagOf_PrimOp WaitReadOp = ILIT(165) -tagOf_PrimOp WaitWriteOp = ILIT(166) - -tagOf_PrimOp ParGlobalOp = ILIT(167) -tagOf_PrimOp ParLocalOp = ILIT(168) -tagOf_PrimOp ParAtOp = ILIT(169) -tagOf_PrimOp ParAtAbsOp = ILIT(170) -tagOf_PrimOp ParAtRelOp = ILIT(171) -tagOf_PrimOp ParAtForNowOp = ILIT(172) -tagOf_PrimOp CopyableOp = ILIT(173) -tagOf_PrimOp NoFollowOp = ILIT(174) +tagOf_PrimOp WriteForeignObjOp = ILIT(156) +tagOf_PrimOp MakeStablePtrOp = ILIT(157) +tagOf_PrimOp DeRefStablePtrOp = ILIT(158) +tagOf_PrimOp (CCallOp _ _ _ _ _) = ILIT(159) +tagOf_PrimOp ErrorIOPrimOp = ILIT(160) +tagOf_PrimOp ReallyUnsafePtrEqualityOp = ILIT(161) +tagOf_PrimOp SeqOp = ILIT(162) +tagOf_PrimOp ParOp = ILIT(163) +tagOf_PrimOp ForkOp = ILIT(164) +tagOf_PrimOp DelayOp = ILIT(165) +tagOf_PrimOp WaitReadOp = ILIT(166) +tagOf_PrimOp WaitWriteOp = ILIT(167) + +tagOf_PrimOp ParGlobalOp = ILIT(168) +tagOf_PrimOp ParLocalOp = ILIT(169) +tagOf_PrimOp ParAtOp = ILIT(170) +tagOf_PrimOp ParAtAbsOp = ILIT(171) +tagOf_PrimOp ParAtRelOp = ILIT(172) +tagOf_PrimOp ParAtForNowOp = ILIT(173) +tagOf_PrimOp CopyableOp = ILIT(174) +tagOf_PrimOp NoFollowOp = ILIT(175) tagOf_PrimOp _ = panic# "tagOf_PrimOp: pattern-match" @@ -597,6 +599,7 @@ allThePrimOps ReadIVarOp, WriteIVarOp, MakeForeignObjOp, + WriteForeignObjOp, MakeStablePtrOp, DeRefStablePtrOp, ReallyUnsafePtrEqualityOp, @@ -1147,7 +1150,7 @@ primOpInfo WaitWriteOp %************************************************************************ %* * -\subsubsection[PrimOps-makeForeignObj]{PrimOpInfo for Foreign Objects} +\subsubsection[PrimOps-ForeignObj]{PrimOpInfo for Foreign Objects} %* * %************************************************************************ @@ -1164,7 +1167,7 @@ When a @ForeignObj@ becomes garbage, a user-defined finalisation routine associated with the object is invoked (currently, each ForeignObj has a direct reference to its finaliser). -- SOF -The only function defined over @ForeignObj@s is: +A @ForeignObj@ is created by the @makeForeignObj#@ primitive: \begin{pseudocode} makeForeignObj# :: Addr# -- foreign object @@ -1172,6 +1175,7 @@ makeForeignObj# :: Addr# -- foreign object -> StateAndForeignObj# _RealWorld# ForeignObj# \end{pseudocode} + \begin{code} primOpInfo MakeForeignObjOp = AlgResult SLIT("makeForeignObj#") [] @@ -1179,6 +1183,34 @@ primOpInfo MakeForeignObjOp stateAndForeignObjPrimTyCon [realWorldTy] \end{code} +[Experimental--SOF] +In addition, another @ForeignObj@ primitive is provided for destructively modifying +the external object wrapped up inside a @ForeignObj@. This primitive is used +when a mixed programming interface of implicit and explicit de-allocation is used, +e.g., if @ForeignObj@s are used to implement @Handle@s, then @Handle@s can be +released either explicitly (through @hClose@) or implicitly (via a finaliser). +When releasing/closing the @Handle@ explicitly, care must be taken to avoid having +the finaliser for the embedded @ForeignObj@ attempt the same thing later. +We deal with this situation, by allowing the programmer to destructively modify +the data field of the @ForeignObj@ to hold a special value the finaliser recognises, +and does not attempt to free (e.g., filling the data slot with \tr{NULL}). + +\begin{pseudocode} +writeForeignObj# :: ForeignObj# -- foreign object + -> Addr# -- new data value + -> StateAndForeignObj# _RealWorld# ForeignObj# +\end{pseudocode} + +\begin{code} +primOpInfo WriteForeignObjOp + = let { + s = alphaTy; s_tv = alphaTyVar + } in + PrimResult SLIT("writeForeignObj#") [s_tv] + [foreignObjPrimTy, addrPrimTy, mkStatePrimTy s] + statePrimTyCon VoidRep [s] +\end{code} + %************************************************************************ %* * \subsubsection[PrimOp-stable-pointers]{PrimOpInfo for ``stable pointers''} @@ -1411,6 +1443,7 @@ primOpHeapReq (CCallOp _ _ mayGC@True _ _) = VariableHeapRequired primOpHeapReq (CCallOp _ _ mayGC@False _ _) = NoHeapRequired primOpHeapReq MakeForeignObjOp = VariableHeapRequired +primOpHeapReq WriteForeignObjOp = NoHeapRequired -- this occasionally has to expand the Stable Pointer table primOpHeapReq MakeStablePtrOp = VariableHeapRequired @@ -1557,7 +1590,8 @@ fragilePrimOp :: PrimOp -> Bool fragilePrimOp ParOp = True fragilePrimOp ForkOp = True fragilePrimOp SeqOp = True -fragilePrimOp MakeForeignObjOp = True -- SOF +fragilePrimOp MakeForeignObjOp = True -- SOF +fragilePrimOp WriteForeignObjOp = True -- SOF fragilePrimOp MakeStablePtrOp = True fragilePrimOp DeRefStablePtrOp = True -- ??? JSM & ADR @@ -1629,6 +1663,7 @@ primOpNeedsWrapper DoubleEncodeOp = True primOpNeedsWrapper DoubleDecodeOp = True primOpNeedsWrapper MakeForeignObjOp = True +primOpNeedsWrapper WriteForeignObjOp = True primOpNeedsWrapper MakeStablePtrOp = True primOpNeedsWrapper DeRefStablePtrOp = True diff --git a/ghc/compiler/reader/Lex.lhs b/ghc/compiler/reader/Lex.lhs index 32f20e9e1f..626762de99 100644 --- a/ghc/compiler/reader/Lex.lhs +++ b/ghc/compiler/reader/Lex.lhs @@ -531,7 +531,7 @@ is_sym c#= '&'# -> True; '*'# -> True; '+'# -> True; '.'# -> True; '/'# -> True; '<'# -> True; '='# -> True; '>'# -> True; '?'# -> True; '\\'# -> True; '^'# -> True; '|'# -> True; - '-'# -> True; '~'# -> True; _ -> False } + '-'# -> True; '~'# -> True; '@'# -> True; _ -> False } --isAlphanum c || c `elem` ":_'!#$%&*+./<=>?@\\^|-~" -- ToDo: add ISOgraphic diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 3024b8e6b3..453fda3343 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -32,7 +32,9 @@ import HsPragmas ( noGenPragmas ) import RdrHsSyn ( SYN_IE(RdrNameHsDecl), SYN_IE(RdrNameInstDecl), RdrName, rdrNameOcc ) -import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn, availName, availNames, addAvailToNameSet ) +import RnEnv ( newGlobalName, lookupRn, addImplicitOccsRn, + availName, availNames, addAvailToNameSet, pprAvail + ) import RnSource ( rnHsType ) import RnMonad import ParseIface ( parseIface ) @@ -275,6 +277,7 @@ importDecl :: Name -> Necessity -> RnMG (Maybe RdrNameHsDecl) importDecl name necessity = checkSlurped name `thenRn` \ already_slurped -> if already_slurped then + -- traceRn (ppSep [ppStr "Already slurped:", ppr PprDebug name]) `thenRn_` returnRn Nothing -- Already dealt with else if isWiredInName name then @@ -336,37 +339,45 @@ that we know just what instances to bring into scope. \begin{code} getWiredInDecl name - = -- Force in the home module in case it has instance decls for - -- the thing we are interested in - (if not is_tycon || mod == gHC__ then - returnRn () -- Mini hack 1: no point for non-tycons; and if we - -- do this we find PrelNum trying to import PackedString, - -- because PrelBase's .hi file mentions PackedString.unpackString - -- But PackedString.hi isn't built by that point! - -- - -- Mini hack 2; GHC is guaranteed not to have - -- instance decls, so it's a waste of time - -- to read it + = get_wired `thenRn` \ avail -> + recordSlurp Nothing avail `thenRn_` + + -- Force in the home module in case it has instance decls for + -- the thing we are interested in. + -- + -- Mini hack 1: no point for non-tycons/class; and if we + -- do this we find PrelNum trying to import PackedString, + -- because PrelBase's .hi file mentions PackedString.unpackString + -- But PackedString.hi isn't built by that point! + -- + -- Mini hack 2; GHC is guaranteed not to have + -- instance decls, so it's a waste of time to read it + -- + -- NB: We *must* look at the availName of the slurped avail, + -- not the name passed to getWiredInDecl! Why? Because if a data constructor + -- or class op is passed to getWiredInDecl we'll pull in the whole data/class + -- decl, and recordSlurp will record that fact. But since the data constructor + -- isn't a tycon/class we won't force in the home module. And even if the + -- type constructor/class comes along later, loadDecl will say that it's already + -- been slurped, so getWiredInDecl won't even be called. Pretty obscure bug, this was. + let + main_name = availName avail + main_is_tc = case avail of { AvailTC _ _ -> True; Avail _ -> False } + (mod,_) = modAndOcc main_name + doc_str = ppSep [ppPStr SLIT("Need home module for wired in thing"), ppr PprDebug name] + in + (if not main_is_tc || mod == gHC__ then + returnRn () else loadInterface doc_str mod `thenRn_` returnRn () ) `thenRn_` - get_wired `thenRn` \ avail -> - recordSlurp Nothing avail `thenRn_` returnRn Nothing -- No declaration to process further where - doc_str = ppSep [ppPStr SLIT("Need home module for wired in thing"), ppr PprDebug name] - (mod,_) = modAndOcc name - maybe_wired_in_tycon = maybeWiredInTyConName name - is_tycon = maybeToBool maybe_wired_in_tycon - maybe_wired_in_id = maybeWiredInIdName name - Just the_tycon = maybe_wired_in_tycon - Just the_id = maybe_wired_in_id get_wired | is_tycon -- ... a type constructor = get_wired_tycon the_tycon - -- Else, must be a wired-in-Id | (isDataCon the_id) -- ... a wired-in data constructor = get_wired_tycon (dataConTyCon the_id) @@ -374,6 +385,12 @@ getWiredInDecl name | otherwise -- ... a wired-in non data-constructor = get_wired_id the_id + maybe_wired_in_tycon = maybeWiredInTyConName name + is_tycon = maybeToBool maybe_wired_in_tycon + maybe_wired_in_id = maybeWiredInIdName name + Just the_tycon = maybe_wired_in_tycon + Just the_id = maybe_wired_in_id + get_wired_id id = addImplicitOccsRn (nameSetToList id_mentioned) `thenRn_` @@ -406,7 +423,8 @@ checkSlurped name returnRn (name `elemNameSet` slurped_names) recordSlurp maybe_version avail - = getIfacesRn `thenRn` \ ifaces -> + = -- traceRn (ppSep [ppStr "Record slurp:", pprAvail PprDebug avail]) `thenRn_` + getIfacesRn `thenRn` \ ifaces -> let Ifaces this_mod mod_vers export_envs decls slurped_names imp_names insts inst_mods = ifaces new_slurped_names = addAvailToNameSet slurped_names avail diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 5d29108b73..8a3ebf69bb 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -468,7 +468,6 @@ addOccurrenceName necessity name (RnDown loc names_var errs_var occs_var) l_down | otherwise = readMutVarSST occs_var `thenSST` \ occs -> --- pprTrace "Add occurrence:" (ppr PprDebug name) $ writeMutVarSST occs_var ((name,necessity) : occs) `thenSST_` returnSST name where diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 0692bd80a4..d49604adaa 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -1291,27 +1291,13 @@ specExpr :: CoreExpr -- expression. specExpr (Var v) args - = specId v $ \ lookupId v `thenSM` \ vlookup -> - case vlookup of - Lifted vl vu - -> -- Binding has been lifted, need to extract un-lifted value - -- NB: a function binding will never be lifted => args always null - -- i.e. no call instance required or call to be constructed - ASSERT (null args) - returnSM (bindUnlift vl vu (Var vu), singleFvUDs (VarArg vl)) - - NoLift vatom@(VarArg new_v) - -> mapSM specOutArg args `thenSM` \ arg_info -> - mkCallInstance v new_v arg_info `thenSM` \ call_uds -> - mkCall new_v arg_info `thenSM` \ call -> - let - call mkGenApp (Var new_id) [arg | (arg, _, _) <- arg_infos]) - uds = unionUDList [call_uds, - singleFvUDs vatom, - unionUDList [uds | (_,uds,_) <- arg_info] - ] - in - returnSM (call, {- tickSpecCall speced -} uds) + = specId v $ \ v_arg -> + case v_arg of + LitArg lit -> ASSERT( null args ) + returnSM (Lit lit, emptyUDs) + + VarArg new_v -> mkCallInstance v new_v args `thenSM` \ uds -> + returnSM (mkGenApp (Var new_v) args, uds) specExpr expr@(Lit _) null_args = ASSERT (null null_args) @@ -1354,9 +1340,8 @@ specPrimOp :: PrimOp specExpr (App fun arg) args - = -- If TyArg, arg will be processed; otherwise, left alone - specArg arg `thenSM` \ new_arg -> - specExpr fun (new_arg : args) `thenSM` \ (expr,uds) -> + = specArg arg `thenSM` \ new_arg -> + specExpr fun (new_arg : args) `thenSM` \ (expr,uds) -> returnSM (expr, uds) specExpr (Lam (ValBinder binder) body) (arg : args) | isValArg arg @@ -1564,18 +1549,18 @@ partition_args args ---------- specId :: Id - -> (Id -> SpecM (CoreExpr, UsageDetails)) + -> (CoreArg -> SpecM (CoreExpr, UsageDetails)) -> SpecM (CoreExpr, UsageDetails) specId v = lookupId v `thenSM` \ vlookup -> case vlookup of Lifted vl vu - -> thing_inside vu `thenSM` \ (expr, uds) -> + -> thing_inside (VarArg vu) `thenSM` \ (expr, uds) -> returnSM (bindUnlift vl vu expr, singleFvUDs (VarArg vl) `unionUDs` uds) NoLift vatom - -> thing_inside vatom `thenSM` \ (expr, uds) -> + -> thing_inside vatom `thenSM` \ (expr, uds) -> returnSM (expr, singleFvUDs vatom `unionUDs` uds) specArg :: CoreArg @@ -1933,7 +1918,7 @@ mkOneInst do_cis@(CallInstance _ spec_tys dict_args _ _) explicit_cis newTyVars (length [() | Nothing <- spec_tys]) `thenSM` \ poly_tyvars -> let -- arg_tys is spec_tys with tyvars instead of the Nothing spec_tys - -- which correspond to unspeciailsed args + -- which correspond to unspecialised args arg_tys :: [Type] (_,arg_tys) = mapAccumL do_the_wotsit poly_tyvars spec_tys @@ -2060,246 +2045,53 @@ mkCallInstance :: Id -> [CoreArg] -> SpecM UsageDetails -mkCallInstance id new_id [] - = returnSM emptyUDs - mkCallInstance id new_id args - - -- No specialised versions for "error" and friends are req'd. - -- This is a special case in core lint etc. - - | isBottomingId id + | null args || -- No args at all + isBottomingId id || -- No point in specialising "error" and friends + -- even at unboxed types + idWantsToBeINLINEd id || -- It's going to be inlined anyway + not enough_args || -- Not enough type and dict args + not interesting_overloading -- Overloaded types are just tyvars = returnSM emptyUDs - -- No call instances for SuperDictSelIds - -- These are a special case in mkCall - - | maybeToBool (isSuperDictSelId_maybe id) - = returnSM emptyUDs - - -- There are also no call instances for ClassOpIds - -- However, we need to process it to get any second-level call - -- instances for a ConstMethodId extracted from its SpecEnv - | otherwise - = let - (tyvars, class_tyvar_pairs) = getIdOverloading id - constrained_tyvars = map snd class_tyvar_pairs -- May contain dups - constraint_vec = [tyvar `elem` constrained_tyvars | tyvar <- tyvars] + = returnSM (singleCI new_id spec_tys dicts) - arg_res = take_type_args tyvars class_tyvar_pairs args - enough_args = maybeToBool arg_res - - - (Just (tys, dicts, rest_args)) = arg_res - - record_spec id tys - = (record, lookup, spec_tys) - where - spec_tys = specialiseCallTys constraint_vec tys - - record = any (not . isTyVarTy) (catMaybes spec_tys) - - lookup = lookupSpecEnv (getIdSpecialisation id) tys - in - if (not enough_args) then - pprTrace "Specialise:recordCallInst: Unsaturated Type & Dict Application:\n\t" - (ppCat (ppr PprDebug id : map (ppr_arg PprDebug) args)) $ - returnSM emptyUDs - - else - case record_spec id tys of - (False, _, _) - -> -- pprTrace "CallInst:NotReqd\n" - -- (ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)]) - (returnSM emptyUDs) - - (True, Nothing, spec_tys) - -> if isClassOpId id then -- No CIs for class ops, dfun will give SPEC inst - returnSM emptyUDs - else - -- pprTrace "CallInst:Reqd\n" - -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppPStr SLIT("CI"), ppCat (map (pprMaybeTy PprDebug) spec_tys), - -- ppCat (map (ppr PprDebug) dicts)]]) - (returnSM (singleCI new_id spec_tys dicts)) - - (True, Just (spec_id, tys_left, toss), _) - -> if maybeToBool (isConstMethodId_maybe spec_id) then - -- If we got a const method spec_id see if further spec required - -- NB: const method is top-level so spec_id will not be cloned - case record_spec spec_id tys_left of - (False, _, _) - -> -- pprTrace "CallInst:Exists\n" - -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id, - -- ppr PprDebug (tys_left ++ drop toss dicts)]]) - (returnSM emptyUDs) - - (True, Nothing, spec_tys) - -> -- pprTrace "CallInst:Exists:Reqd\n" - -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id, - -- ppr PprDebug (tys_left ++ drop toss dicts)], - -- ppCat [ppPStr SLIT("CI"), ppCat (map (pprMaybeTy PprDebug) spec_tys), - -- ppCat (map (ppr PprDebug) (drop toss dicts))]]) - (returnSM (singleCI spec_id spec_tys (drop toss dicts))) - - (True, Just (spec_spec_id, tys_left_left, toss_toss), _) - -> -- pprTrace "CallInst:Exists:Exists\n" - -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id, - -- ppr PprDebug (tys_left ++ drop toss dicts)], - -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_spec_id, - -- ppr PprDebug (tys_left_left ++ drop (toss + toss_toss) dicts)]]) - (returnSM emptyUDs) - - else - -- pprTrace "CallInst:Exists\n" - -- (ppAboves [ppCat [ppr PprDebug id, ppCat (map (ppr PprDebug) args)], - -- ppCat [ppPStr SLIT("->"), ppr PprDebug spec_id, - -- ppr PprDebug (tys_left ++ drop toss dicts)]]) - (returnSM emptyUDs) - - -take_type_args (_:tyvars) class_tyvar_pairs (TyArg ty : args) - = case (take_type_args tyvars class_tyvar_pairs args) of - Nothing -> Nothing + where + (tyvars, class_tyvar_pairs) = getIdOverloading id + constrained_tyvars = map snd class_tyvar_pairs -- May contain dups + constraint_vec = [tyvar `elem` constrained_tyvars | tyvar <- tyvars] + + arg_res = take_type_args tyvars class_tyvar_pairs args + enough_args = maybeToBool arg_res + (Just (tys, dicts, rest_args)) = arg_res + + interesting_overloading = any (not . isTyVarTy) (catMaybes spec_tys) + spec_tys = specialiseCallTys constraint_vec tys + + ----------------- Rather a gruesome help-function --------------- + take_type_args (_:tyvars) (TyArg ty : args) + = case (take_type_args tyvars args) of + Nothing -> Nothing Just (tys, dicts, others) -> Just (ty:tys, dicts, others) -take_type_args (_:tyvars) class_tyvar_pairs [] = Nothing + take_type_args (_:tyvars) [] = Nothing -take_type_args [] class_tyvar_pairs args + take_type_args [] args = case (take_dict_args class_tyvar_pairs args) of Nothing -> Nothing Just (dicts, others) -> Just ([], dicts, others) -take_dict_args (_:class_tyvar_pairs) (dict : args) | isValArg dict + take_dict_args (_:class_tyvar_pairs) (dict : args) | isValArg dict = case (take_dict_args class_tyvar_pairs args) of Nothing -> Nothing Just (dicts, others) -> Just (dict:dicts, others) -take_dict_args (_:class_tyvar_pairs) [] = Nothing + take_dict_args (_:class_tyvar_pairs) args = Nothing -take_dict_args [] args = Just ([], args) + take_dict_args [] args = Just ([], args) \end{code} -\begin{code} -mkCall :: Id - -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)] - -> SpecM CoreExpr - -mkCall new_id arg_infos = returnSM ( - -{- - | maybeToBool (isSuperDictSelId_maybe new_id) - && any isUnboxedType ty_args - -- No specialisations for super-dict selectors - -- Specialise unboxed calls to SuperDictSelIds by extracting - -- the super class dictionary directly form the super class - -- NB: This should be dead code since all uses of this dictionary should - -- have been specialised. We only do this to keep core-lint happy. - = let - Just (_, super_class) = isSuperDictSelId_maybe new_id - super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of - Nothing -> panic "Specialise:mkCall:SuperDictId" - Just id -> id - in - returnSM (False, Var super_dict_id) - - | otherwise - = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of - Nothing -> checkUnspecOK new_id ty_args ( - returnSM (False, unspec_call) - ) - - Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1) - -> let - -- It may be necessary to specialsie a constant method spec_id again - (spec_id, tys_left, dicts_to_toss) = - case (maybeToBool (isConstMethodId_maybe spec_id_1), - lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of - (False, _ ) -> spec_1_details - (True, Nothing) -> spec_1_details - (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2)) - -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2) - - args_left = toss_dicts dicts_to_toss val_args - in - checkSpecOK new_id ty_args spec_id tys_left ( - - -- The resulting spec_id may be a top-level unboxed value - -- This can arise for: - -- 1) constant method values - -- eq: class Num a where pi :: a - -- instance Num Double# where pi = 3.141# - -- 2) specilised overloaded values - -- eq: i1 :: Num a => a - -- i1 Int# d.Num.Int# ==> i1.Int# - -- These top level defns should have been lifted. - -- We must add code to unlift such a spec_id. - - if isUnboxedType (idType spec_id) then - ASSERT (null tys_left && null args_left) - if toplevelishId spec_id then - liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) -> - returnSM (True, bindUnlift lift_spec_id unlift_spec_id - (Var unlift_spec_id)) - else - pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n" - (ppCat [ppr PprDebug new_id, - ppInterleave ppNil (map (pprParendGenType PprDebug) ty_args), - ppPStr SLIT("==>"), - ppr PprDebug spec_id]) - else - let - (vals_left, _, unlifts_left) = unzip3 args_left - applied_tys = mkTyApp (Var spec_id) tys_left - applied_vals = mkGenApp applied_tys vals_left - in - returnSM (True, applyBindUnlifts unlifts_left applied_vals) - ) - where - (tys_and_vals, _, unlifts) = unzip3 args - unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals) - - - -- ty_args is the types at the front of the arg list - -- val_args is the rest of the arg-list - - (ty_args, val_args) = get args - where - get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args - get args = ([], args) - - - -- toss_dicts chucks away dict args, checking that they ain't types! - toss_dicts 0 args = args - toss_dicts n ((a,_,_) : args) - | isValArg a = toss_dicts (n-1) args - -\end{code} - -\begin{code} -checkUnspecOK :: Id -> [Type] -> a -> a -checkUnspecOK check_id tys - = if isLocallyDefined check_id && any isUnboxedType tys - then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n" - (ppCat [ppr PprDebug check_id, - ppInterleave ppNil (map (pprParendGenType PprDebug) tys)]) - else id - -checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a -checkSpecOK check_id tys spec_id tys_left - = if any isUnboxedType tys_left - then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n" - (ppAboves [ppCat [ppr PprDebug check_id, - ppInterleave ppNil (map (pprParendGenType PprDebug) tys)], - ppCat [ppr PprDebug spec_id, - ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]]) - else id --} -\end{code} \begin{code} mkTyConInstance :: Id @@ -2374,8 +2166,7 @@ type SpecM result -> UniqSupply -> result -initSM m uniqs - = m nullTyVarEnv nullIdEnv uniqs +initSM m uniqs = m nullTyVarEnv nullIdEnv uniqs returnSM :: a -> SpecM a thenSM :: SpecM a -> (a -> SpecM b) -> SpecM b @@ -2404,7 +2195,7 @@ newSpecIds :: [Id] -- The id of which to make a specialised version newSpecIds new_ids maybe_tys dicts_to_ignore tvenv idenv us = [ mkSpecId uniq id maybe_tys (spec_id_ty id) (selectIdInfoForSpecId id) - | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ] + | (id,uniq) <- zipEqual "newSpecIds" new_ids uniqs ] where uniqs = getUniques (length new_ids) us spec_id_ty id = specialiseTy (idType id) maybe_tys dicts_to_ignore @@ -2592,3 +2383,124 @@ mapAndUnzip4SM f (x:xs) = f x `thenSM` \ (r1,r2,r3,r4) -> returnSM ((r1:rs1),(r2:rs2),(r3:rs3),(r4:rs4)) -} \end{code} + + + +===================== OLD CODE, scheduled for deletion ================= + +\begin{code} +{- +mkCall :: Id + -> [(CoreArg, UsageDetails, CoreExpr -> CoreExpr)] + -> SpecM CoreExpr + +mkCall new_id arg_infos = returnSM ( + + | maybeToBool (isSuperDictSelId_maybe new_id) + && any isUnboxedType ty_args + -- No specialisations for super-dict selectors + -- Specialise unboxed calls to SuperDictSelIds by extracting + -- the super class dictionary directly form the super class + -- NB: This should be dead code since all uses of this dictionary should + -- have been specialised. We only do this to keep core-lint happy. + = let + Just (_, super_class) = isSuperDictSelId_maybe new_id + super_dict_id = case lookupClassInstAtSimpleType super_class (head ty_args) of + Nothing -> panic "Specialise:mkCall:SuperDictId" + Just id -> id + in + returnSM (False, Var super_dict_id) + + | otherwise + = case lookupSpecEnv (getIdSpecialisation new_id) ty_args of + Nothing -> checkUnspecOK new_id ty_args ( + returnSM (False, unspec_call) + ) + + Just spec_1_details@(spec_id_1, tys_left_1, dicts_to_toss_1) + -> let + -- It may be necessary to specialsie a constant method spec_id again + (spec_id, tys_left, dicts_to_toss) = + case (maybeToBool (isConstMethodId_maybe spec_id_1), + lookupSpecEnv (getIdSpecialisation spec_id_1) tys_left_1) of + (False, _ ) -> spec_1_details + (True, Nothing) -> spec_1_details + (True, Just (spec_id_2, tys_left_2, dicts_to_toss_2)) + -> (spec_id_2, tys_left_2, dicts_to_toss_1 + dicts_to_toss_2) + + args_left = toss_dicts dicts_to_toss val_args + in + checkSpecOK new_id ty_args spec_id tys_left ( + + -- The resulting spec_id may be a top-level unboxed value + -- This can arise for: + -- 1) constant method values + -- eq: class Num a where pi :: a + -- instance Num Double# where pi = 3.141# + -- 2) specilised overloaded values + -- eq: i1 :: Num a => a + -- i1 Int# d.Num.Int# ==> i1.Int# + -- These top level defns should have been lifted. + -- We must add code to unlift such a spec_id. + + if isUnboxedType (idType spec_id) then + ASSERT (null tys_left && null args_left) + if toplevelishId spec_id then + liftId spec_id `thenSM` \ (lift_spec_id, unlift_spec_id) -> + returnSM (True, bindUnlift lift_spec_id unlift_spec_id + (Var unlift_spec_id)) + else + pprPanic "Specialise:mkCall: unboxed spec_id not top-level ...\n" + (ppCat [ppr PprDebug new_id, + ppInterleave ppNil (map (pprParendGenType PprDebug) ty_args), + ppPStr SLIT("==>"), + ppr PprDebug spec_id]) + else + let + (vals_left, _, unlifts_left) = unzip3 args_left + applied_tys = mkTyApp (Var spec_id) tys_left + applied_vals = mkGenApp applied_tys vals_left + in + returnSM (True, applyBindUnlifts unlifts_left applied_vals) + ) + where + (tys_and_vals, _, unlifts) = unzip3 args + unspec_call = applyBindUnlifts unlifts (mkGenApp (Var new_id) tys_and_vals) + + + -- ty_args is the types at the front of the arg list + -- val_args is the rest of the arg-list + + (ty_args, val_args) = get args + where + get ((TyArg ty,_,_) : args) = (ty : tys, rest) where (tys,rest) = get args + get args = ([], args) + + + -- toss_dicts chucks away dict args, checking that they ain't types! + toss_dicts 0 args = args + toss_dicts n ((a,_,_) : args) + | isValArg a = toss_dicts (n-1) args + +\end{code} + +\begin{code} +checkUnspecOK :: Id -> [Type] -> a -> a +checkUnspecOK check_id tys + = if isLocallyDefined check_id && any isUnboxedType tys + then pprPanic "Specialise:checkUnspecOK: unboxed instance for local id not found\n" + (ppCat [ppr PprDebug check_id, + ppInterleave ppNil (map (pprParendGenType PprDebug) tys)]) + else id + +checkSpecOK :: Id -> [Type] -> Id -> [Type] -> a -> a +checkSpecOK check_id tys spec_id tys_left + = if any isUnboxedType tys_left + then pprPanic "Specialise:checkSpecOK: unboxed type args in specialised application\n" + (ppAboves [ppCat [ppr PprDebug check_id, + ppInterleave ppNil (map (pprParendGenType PprDebug) tys)], + ppCat [ppr PprDebug spec_id, + ppInterleave ppNil (map (pprParendGenType PprDebug) tys_left)]]) + else id +-} +\end{code} diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index e589426935..4587e182c0 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -366,6 +366,8 @@ we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a \begin{verbatim} instance ... Enum (Foo ...) where + toEnum i = tag2con_Foo i + enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo] -- or, really... @@ -390,11 +392,17 @@ For @enumFromTo@ and @enumFromThenTo@, we use the default methods. gen_Enum_binds :: TyCon -> RdrNameMonoBinds gen_Enum_binds tycon - = enum_from `AndMonoBinds` + = to_enum `AndMonoBinds` + enum_from `AndMonoBinds` enum_from_then `AndMonoBinds` from_enum where tycon_loc = getSrcLoc tycon + + to_enum + = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $ + mk_easy_App (tag2con_RDR tycon) [a_RDR] + enum_from = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $ untag_Expr tycon [(a_RDR, ah_RDR)] $ diff --git a/ghc/compiler/utils/FastString.lhs b/ghc/compiler/utils/FastString.lhs index ab54af7784..21f61fda20 100644 --- a/ghc/compiler/utils/FastString.lhs +++ b/ghc/compiler/utils/FastString.lhs @@ -134,10 +134,10 @@ concatFS :: [FastString] -> FastString concatFS ls = mkFastString (concat (map (unpackFS) ls)) -- ToDo: do better headFS :: FastString -> Char -headFS (FastString _ l# ba#) = - if l# ># 0# then C# (indexCharArray# ba# 0#) else error "headFS: empty FS" -headFS (CharStr a# l#) = - if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error "headFS: empty FS" +headFS f@(FastString _ l# ba#) = + if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS: " ++ unpackFS f) +headFS f@(CharStr a# l#) = + if l# ># 0# then C# (indexCharOffAddr# a# 0#) else error ("headFS: empty FS: " ++ unpackFS f) tailFS :: FastString -> FastString tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#) diff --git a/ghc/docs/Makefile b/ghc/docs/Makefile index 2f99b93e63..cf8be1f57f 100644 --- a/ghc/docs/Makefile +++ b/ghc/docs/Makefile @@ -6,6 +6,6 @@ include $(TOP)/mk/boilerplate.mk # export WAYS= -SUBDIRS = users_guide install_guide release_notes state_interface +SUBDIRS = users_guide include $(TOP)/mk/target.mk diff --git a/ghc/driver/ghc-asm.lprl b/ghc/driver/ghc-asm.lprl index f24343343d..89cc4b1ca7 100644 --- a/ghc/driver/ghc-asm.lprl +++ b/ghc/driver/ghc-asm.lprl @@ -348,9 +348,20 @@ sub mangle_asm { # multi-line regexp matching: local($*) = 1; local($i, $c); + + &init_TARGET_STUFF(); &init_FUNNY_THINGS(); + # perl4 on alphas SEGVs when give ${foo} substitutions in patterns. + # To avoid them we declare some locals that allows to avoid using curlies. + local($TUS) = ${T_US}; + local($TPOSTLBL) = ${T_POST_LBL}; + local($TMOVEDIRVS) = ${T_MOVE_DIRVS}; + local($TPREAPP) = ${T_PRE_APP}; + local($TCOPYDIRVS) = ${T_COPY_DIRVS}; + local($TDOTWORD) = ${T_DOT_WORD}; + open(INASM, "< $in_asmf") || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); open(OUTASM,"> $out_asmf") @@ -374,10 +385,9 @@ sub mangle_asm { $i = 0; $chkcat[0] = 'misc'; $chk[0] = ''; while (<INASM>) { - next if $T_STABBY && /^\.stab.*${T_US}__stg_split_marker/o; + next if $T_STABBY && /^\.stab.*$TUS[@]?__stg_split_marker/o; next if $T_STABBY && /^\.stab.*ghc.*c_ID/; - next if /${T_PRE_APP}(NO_)?APP/o; - + next if /$TPREAPP(NO_)?APP/o; next if /^;/ && $TargetPlatform =~ /^hppa/; next if /(^$|^\t\.file\t|^ # )/ && $TargetPlatform =~ /^(mips|powerpc)-/; @@ -408,12 +418,12 @@ sub mangle_asm { $chkcat[$i] = 'literal'; $chksymb[$i] = $1; - } elsif ( /^${T_US}__stg_split_marker(\d+)${T_POST_LBL}$/o ) { + } elsif ( /^$TUS[@]?__stg_split_marker(\d+)$TPOSTLBL[@]?$/o ) { $chk[++$i] = $_; $chkcat[$i] = 'splitmarker'; $chksymb[$i] = $1; - } elsif ( /^${T_US}([A-Za-z0-9_]+)_info${T_POST_LBL}$/o ) { + } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_info$TPOSTLBL[@]?$/o ) { $symb = $1; $chk[++$i] = $_; $chkcat[$i] = 'infotbl'; @@ -423,40 +433,40 @@ sub mangle_asm { $infochk{$symb} = $i; - } elsif ( /^${T_US}([A-Za-z0-9_]+)_entry${T_POST_LBL}$/o ) { + } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_entry$TPOSTLBL[@]?$/o ) { $chk[++$i] = $_; $chkcat[$i] = 'slow'; $chksymb[$i] = $1; $slowchk{$1} = $i; - } elsif ( /^${T_US}([A-Za-z0-9_]+)_fast\d+${T_POST_LBL}$/o ) { + } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_fast\d+$TPOSTLBL[@]?$/o ) { $chk[++$i] = $_; $chkcat[$i] = 'fast'; $chksymb[$i] = $1; $fastchk{$1} = $i; - } elsif ( /^${T_US}([A-Za-z0-9_]+)_closure${T_POST_LBL}$/o ) { + } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)_closure$TPOSTLBL[@]?$/o ) { $chk[++$i] = $_; $chkcat[$i] = 'closure'; $chksymb[$i] = $1; $closurechk{$1} = $i; - } elsif ( /^${T_US}ghc.*c_ID${T_POST_LBL}/o ) { + } elsif ( /^$TUS[@]?ghc.*c_ID$TPOSTLBL/o ) { $chk[++$i] = $_; $chkcat[$i] = 'consist'; - } elsif ( /^(${T_US}__gnu_compiled_c|gcc2_compiled\.)${T_POST_LBL}/o ) { + } elsif ( /^($TUS[@]?__gnu_compiled_c|gcc2_compiled\.)$TPOSTLBL/o ) { ; # toss it - } elsif ( /^${T_US}ErrorIO_call_count${T_POST_LBL}$/o # HACK!!!! - || /^${T_US}[A-Za-z0-9_]+\.\d+${T_POST_LBL}$/o - || /^${T_US}.*_CAT${T_POST_LBL}$/o # PROF: _entryname_CAT - || /^${T_US}CC_.*_struct${T_POST_LBL}$/o # PROF: _CC_ccident_struct - || /^${T_US}.*_done${T_POST_LBL}$/o # PROF: _module_done - || /^${T_US}_module_registered${T_POST_LBL}$/o # PROF: _module_registered + } elsif ( /^$TUS[@]?ErrorIO_call_count$TPOSTLBL[@]?$/o # HACK!!!! + || /^$TUS[A-Za-z0-9_]+\.\d+$TPOSTLBL[@]?$/o + || /^$TUS[@]?.*_CAT$TPOSTLBL[@]?$/o # PROF: _entryname_CAT + || /^$TUS[@]?CC_.*_struct$TPOSTLBL[@]?$/o # PROF: _CC_ccident_struct + || /^$TUS[@]?.*_done$TPOSTLBL[@]?$/o # PROF: _module_done + || /^$TUS[@]?_module_registered$TPOSTLBL[@]?$/o # PROF: _module_registered ) { $chk[++$i] = $_; $chkcat[$i] = 'data'; @@ -467,26 +477,26 @@ sub mangle_asm { $chkcat[$i] = 'bss'; $chksymb[$i] = $1; - } elsif ( /^${T_US}(ret_|djn_)/o ) { + } elsif ( /^$TUS[@]?(ret_|djn_)/o ) { $chk[++$i] = $_; $chkcat[$i] = 'misc'; $chksymb[$i] = ''; - } elsif ( /^${T_US}vtbl_([A-Za-z0-9_]+)${T_POST_LBL}$/o ) { + } elsif ( /^$TUS[@]?vtbl_([A-Za-z0-9_]+)$TPOSTLBL[@]?$/o ) { $chk[++$i] = $_; $chkcat[$i] = 'vector'; $chksymb[$i] = $1; $vectorchk{$1} = $i; - } elsif ( /^${T_US}([A-Za-z0-9_]+)DirectReturn${T_POST_LBL}$/o ) { + } elsif ( /^$TUS[@]?([A-Za-z0-9_]+)DirectReturn$TPOSTLBL[@]?$/o ) { $chk[++$i] = $_; $chkcat[$i] = 'direct'; $chksymb[$i] = $1; $directchk{$1} = $i; - } elsif ( /^${T_US}[A-Za-z0-9_]+_upd${T_POST_LBL}$/o ) { + } elsif ( /^$TUS[@]?[A-Za-z0-9_]+_upd$TPOSTLBL[@]?$/o ) { $chk[++$i] = $_; $chkcat[$i] = 'misc'; $chksymb[$i] = ''; @@ -506,7 +516,7 @@ sub mangle_asm { $chkcat[$i] = 'toss'; $chksymb[$i] = $1; - } elsif ( /^${T_US}[A-Za-z0-9_]/o + } elsif ( /^$TUS[@]?[A-Za-z0-9_]/o && ( $TargetPlatform !~ /^hppa/ # need to avoid local labels in this case || ! /^L\$\d+$/ ) && ( $TargetPlatform !~ /^powerpc/ # ditto @@ -515,9 +525,9 @@ sub mangle_asm { chop($thing = $_); print STDERR "Funny global thing?: $_" unless $KNOWN_FUNNY_THING{$thing} - || /^${T_US}_(PRIn|PRStart).*${T_POST_LBL}$/o # pointer reversal GC routines - || /^${T_US}CC_.*${T_POST_LBL}$/o # PROF: _CC_ccident - || /^${T_US}_reg.*${T_POST_LBL}$/o; # PROF: __reg<module> + || /^$TUS[@]?_(PRIn|PRStart).*$TPOSTLBL[@]?$/o # pointer reversal GC routines + || /^$TUS[@]?CC_.*$TPOSTLBL$/o # PROF: _CC_ccident ([@]? is a silly hack (see above)) + || /^$TUS[@]?_reg.*$TPOSTLBL$/o; # PROF: __reg<module> $chk[++$i] = $_; $chkcat[$i] = 'misc'; $chksymb[$i] = ''; @@ -644,7 +654,7 @@ sub mangle_asm { # On Alphas, the prologue mangling is done a little later (below) # toss all calls to __DISCARD__ - $c =~ s/^\t(call|jbsr|jal)\s+${T_US}__DISCARD__\n//go; + $c =~ s/^\t(call|jbsr|jal)\s+$TUS[@]?__DISCARD__\n//go; # MIPS: that may leave some gratuitous asm macros around # (no harm done; but we get rid of them to be tidier) @@ -667,16 +677,18 @@ sub mangle_asm { # pin a funny end-thing on (for easier matching): $c .= 'FUNNY#END#THING'; - while ( $c =~ /${T_MOVE_DIRVS}FUNNY#END#THING/o ) { + while ( $c =~ /$TMOVEDIRVS[@]?FUNNY#END#THING/o ) { # [@]? is a silly hack to avoid having to use curlies for T_PRE_APP + # (this SEGVs perl4 on alphas, you see) + $to_move = $1; if ( $i < ($numchks - 1) - && ( $to_move =~ /${T_COPY_DIRVS}/ + && ( $to_move =~ /$TCOPYDIRVS/ || ($TargetPlatform =~ /^hppa/ && $to_move =~ /align/ && $chkcat[$i+1] eq 'literal') )) { $chk[$i + 1] = $to_move . $chk[$i + 1]; # otherwise they're tossed } - $c =~ s/${T_MOVE_DIRVS}FUNNY#END#THING/FUNNY#END#THING/o; + $c =~ s/$TMOVEDIRVS[@]?FUNNY#END#THING/FUNNY#END#THING/o; # [@]? is a hack (see above) } if ( $TargetPlatform =~ /^alpha-/ && $c =~ /^\t\.ent\s+(\S+)/ ) { @@ -816,7 +828,7 @@ sub mangle_asm { # entry code will be put here! # paranoia - if ( $chk[$infochk{$symb}] =~ /${T_DOT_WORD}\s+([A-Za-z0-9_]+_entry)$/o + if ( $chk[$infochk{$symb}] =~ /$TDOTWORD[@]?\s+([A-Za-z0-9_]+_entry)$/o && $1 ne "${T_US}${symb}_entry" ) { print STDERR "!!! entry point???\n",$chk[$infochk{$symb}]; } @@ -856,7 +868,7 @@ sub mangle_asm { # references to fast-entry point. # (questionable re hppa and mips...) print STDERR "still has jump to fast entry point:\n$c" - if $c =~ /${T_US}${symb}_fast/; # NB: paranoia + if $c =~ /$TUS[@]?$symb[@]?_fast/; # NB: paranoia } print OUTASM $T_HDR_entry; @@ -1218,18 +1230,24 @@ sub rev_tbl { local($after) = ''; local(@lines) = split(/\n/, $tbl); local($i, $extra, $words_to_pad, $j); - - for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t${T_DOT_WORD}\s+/o; $i++) { + + # see comment in mangleAsm as to why this silliness is needed. + local($TDOTWORD) = ${T_DOT_WORD}; + local($TDOTGLOBAL) = ${T_DOT_GLOBAL}; + local($TUS) = ${T_US}; + local($TPOSTLBL) = ${T_POST_LBL}; + + for ($i = 0; $i <= $#lines && $lines[$i] !~ /^\t$TDOTWORD\s+/o; $i++) { $label .= $lines[$i] . "\n", - next if $lines[$i] =~ /^[A-Za-z0-9_]+_info${T_POST_LBL}$/o - || $lines[$i] =~ /${T_DOT_GLOBAL}/o - || $lines[$i] =~ /^${T_US}vtbl_\S+${T_POST_LBL}$/o; + next if $lines[$i] =~ /^[A-Za-z0-9_]+_info$TPOSTLBL[@]?$/o + || $lines[$i] =~ /$TDOTGLOBAL/o + || $lines[$i] =~ /^$TUS[@]?vtbl_\S+$TPOSTLBL[@]?$/o; $before .= $lines[$i] . "\n"; # otherwise... } if ( $TargetPlatform !~ /^hppa/ ) { - for ( ; $i <= $#lines && $lines[$i] =~ /^\t${T_DOT_WORD}\s+/o; $i++) { + for ( ; $i <= $#lines && $lines[$i] =~ /^\t$TDOTWORD\s+/o; $i++) { push(@words, $lines[$i]); } } else { # hppa weirdness @@ -1287,6 +1305,10 @@ sub mini_mangle_asm_i386 { &init_TARGET_STUFF(); + # see mangleAsm comment + local($TUS) = ${T_US}; + local($TPOSTLBL)=${T_POST_LBL}; + open(INASM, "< $in_asmf") || &tidy_up_and_die(1,"$Pgm: failed to open `$in_asmf' (to read)\n"); open(OUTASM,"> $out_asmf") @@ -1296,7 +1318,7 @@ sub mini_mangle_asm_i386 { print OUTASM; next unless - /^${T_US}(PerformGC|StackOverflow|Yield|PerformReschedule)_wrapper${T_POST_LBL}\n/o; + /^$TUS[@]?(PerformGC|StackOverflow|Yield|PerformReschedule)_wrapper$TPOSTLBL\n/o; print OUTASM "\tmovl \%esp, ${T_US}__temp_esp\n"; print OUTASM "\tmovl \%eax, ${T_US}__temp_eax\n"; } diff --git a/ghc/includes/StgMacros.lh b/ghc/includes/StgMacros.lh index 3732beb44d..56d6523337 100644 --- a/ghc/includes/StgMacros.lh +++ b/ghc/includes/StgMacros.lh @@ -2094,7 +2094,7 @@ do { \ StorageMgrInfo.ForeignObjList = result; \ \ \ -/*fprintf(stderr,"DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n", \ + /*fprintf(stderr,"DEBUG: ForeignObj(0x%x) = <0x%x, 0x%x, 0x%x, 0x%x>\n", \ result, \ result[0],result[1], \ result[2],result[3]);*/ \ @@ -2105,6 +2105,8 @@ do { \ (r) = (P_) result; \ } while (0) +#define writeForeignObjZh(res,datum) ((PP_) ForeignObj_CLOSURE_DATA(res)) = ((P_)datum) + #else #define makeForeignObjZh(r, liveness, mptr, finalise) \ do { \ @@ -2113,6 +2115,13 @@ do { \ EXIT(EXIT_FAILURE); \ } while(0) +#define writeForeignObjZh(res,datum) \ +do { \ + fflush(stdout); \ + fprintf(stderr, "writeForeignObj#: no foreign object support.\n");\ + EXIT(EXIT_FAILURE); \ +} while(0) + #endif /* !PAR */ \end{code} diff --git a/ghc/lib/Makefile b/ghc/lib/Makefile index 6236c38ffa..76e8dbfa60 100644 --- a/ghc/lib/Makefile +++ b/ghc/lib/Makefile @@ -4,7 +4,7 @@ # # Makefile for building the GHC Prelude libraries umpteen ways # -# $Id: Makefile,v 1.5 1997/03/14 05:30:36 sof Exp $ +# $Id: Makefile,v 1.6 1997/03/17 20:34:49 simonpj Exp $ # # ################################################################################# @@ -52,14 +52,15 @@ endif # per-module flags -ghc/PackedString_HC_OPTS = -monly-3-regs -required/Directory_HC_OPTS = -monly-3-regs -concurrent/Parallel_HC_OPTS = -fglasgow-exts +ghc/PackedString_HC_OPTS += -monly-3-regs +required/Directory_HC_OPTS += -monly-3-regs +concurrent/Parallel_HC_OPTS += -fglasgow-exts +required/Time_HC_OPTS += -monly-3-regs #----------------------------------------------------------------------------- # Dependency generation -SRC_MKDEPENDHS_OPTS += -irequired:ghc:hbc:glaExts:concurrent +SRC_MKDEPENDHS_OPTS += -irequired:ghc:hbc:glaExts:concurrent -I$(GHC_INCLUDE_DIR) #----------------------------------------------------------------------------- # Rules diff --git a/ghc/lib/cbits/stgio.h b/ghc/lib/cbits/stgio.h index 8c0d2cb8be..d6b9b02f1c 100644 --- a/ghc/lib/cbits/stgio.h +++ b/ghc/lib/cbits/stgio.h @@ -59,6 +59,10 @@ StgInt getBufferMode PROTO((StgForeignObj)); /* getClockTime.lc */ StgInt getClockTime PROTO((StgByteArray, StgByteArray)); +StgAddr showTime PROTO((I_, StgByteArray, StgByteArray)); +StgAddr toClockSec PROTO((I_, I_, I_, I_, I_, I_, I_, StgByteArray)); +StgAddr toLocalTime PROTO((I_, StgByteArray, StgByteArray)); +StgAddr toUTCTime PROTO((I_, StgByteArray, StgByteArray)); /* getCPUTime.lc */ StgByteArray getCPUTime PROTO((StgByteArray)); diff --git a/ghc/lib/ghc/GHC.hi-boot b/ghc/lib/ghc/GHC.hi-boot index 884bba09ac..d751f95ec5 100644 --- a/ghc/lib/ghc/GHC.hi-boot +++ b/ghc/lib/ghc/GHC.hi-boot @@ -210,6 +210,7 @@ indexAddrOffAddr# ForeignObj# makeForeignObj# + writeForeignObj# StablePtr# makeStablePtr# diff --git a/ghc/lib/ghc/IOBase.lhs b/ghc/lib/ghc/IOBase.lhs index 4a952f718f..8f1ad2553f 100644 --- a/ghc/lib/ghc/IOBase.lhs +++ b/ghc/lib/ghc/IOBase.lhs @@ -399,11 +399,19 @@ type Handle = MutableVar RealWorld Handle__ data Handle__ = ErrorHandle IOError | ClosedHandle +#ifndef PAR | SemiClosedHandle ForeignObj (Addr, Int) | ReadHandle ForeignObj (Maybe BufferMode) Bool | WriteHandle ForeignObj (Maybe BufferMode) Bool | AppendHandle ForeignObj (Maybe BufferMode) Bool | ReadWriteHandle ForeignObj (Maybe BufferMode) Bool +#else + | SemiClosedHandle Addr (Addr, Int) + | ReadHandle Addr (Maybe BufferMode) Bool + | WriteHandle Addr (Maybe BufferMode) Bool + | AppendHandle Addr (Maybe BufferMode) Bool + | ReadWriteHandle Addr (Maybe BufferMode) Bool +#endif -- Standard Instances as defined by the Report.. diff --git a/ghc/lib/ghc/IOHandle.lhs b/ghc/lib/ghc/IOHandle.lhs index 50e1300c98..a3f64ceb6e 100644 --- a/ghc/lib/ghc/IOHandle.lhs +++ b/ghc/lib/ghc/IOHandle.lhs @@ -23,7 +23,7 @@ import IOBase import PrelTup import PrelBase import GHC -import Foreign ( makeForeignObj ) +import Foreign ( makeForeignObj, writeForeignObj ) import PrelList (span) #if defined(__CONCURRENT_HASKELL__) import ConcBase @@ -68,7 +68,11 @@ writeHandle h v = stToIO (writeVar h v) %********************************************************* \begin{code} +#ifndef PAR filePtr :: Handle__ -> ForeignObj +#else +filePtr :: Handle__ -> Addr +#endif filePtr (SemiClosedHandle fp _) = fp filePtr (ReadHandle fp _ _) = fp filePtr (WriteHandle fp _ _) = fp @@ -116,8 +120,13 @@ stdin = unsafePerformPrimIO ( _ccall_ getLock (``stdin''::Addr) 0 >>= \ rc -> (case rc of 0 -> new_handle ClosedHandle - 1 -> makeForeignObj (``stdin''::Addr) (``&freeStdChannel''::Addr) >>= \ fp -> + 1 -> +#ifndef PAR + makeForeignObj (``stdin''::Addr) (``&freeStdChannel''::Addr) >>= \ fp -> new_handle (ReadHandle fp Nothing False) +#else + new_handle (ReadHandle ``stdin'' Nothing False) +#endif _ -> constructError "stdin" >>= \ ioError -> new_handle (ErrorHandle ioError) ) >>= \ handle -> @@ -130,8 +139,13 @@ stdout = unsafePerformPrimIO ( _ccall_ getLock (``stdout''::Addr) 1 >>= \ rc -> (case rc of 0 -> new_handle ClosedHandle - 1 -> makeForeignObj (``stdout''::Addr) (``&freeStdChannel''::Addr) >>= \ fp -> + 1 -> +#ifndef PAR + makeForeignObj (``stdout''::Addr) (``&freeStdChannel''::Addr) >>= \ fp -> new_handle (WriteHandle fp Nothing False) +#else + new_handle (WriteHandle ``stdout'' Nothing False) +#endif _ -> constructError "stdout" >>= \ ioError -> new_handle (ErrorHandle ioError) ) >>= \ handle -> @@ -144,8 +158,13 @@ stderr = unsafePerformPrimIO ( _ccall_ getLock (``stderr''::Addr) 1 >>= \ rc -> (case rc of 0 -> new_handle ClosedHandle - 1 -> makeForeignObj (``stderr''::Addr) (``&freeStdChannel''::Addr) >>= \ fp -> + 1 -> +#ifndef PAR + makeForeignObj (``stderr''::Addr) (``&freeStdChannel''::Addr) >>= \ fp -> new_handle (WriteHandle fp (Just NoBuffering) False) +#else + new_handle (WriteHandle ``stderr'' (Just NoBuffering) False) +#endif _ -> constructError "stderr" >>= \ ioError -> new_handle (ErrorHandle ioError) ) >>= \ handle -> @@ -170,8 +189,12 @@ openFile :: FilePath -> IOMode -> IO Handle openFile f m = stToIO (_ccall_ openFile f m') >>= \ ptr -> if ptr /= ``NULL'' then - stToIO (makeForeignObj ptr ((``&freeFile'')::Addr)) >>= \ fp -> +#ifndef PAR + makeForeignObj ptr ((``&freeFile'')::Addr) `thenIO_Prim` \ fp -> newHandle (htype fp Nothing False) +#else + newHandle (htype ptr Nothing False) +#endif else stToIO (constructError "openFile") >>= \ ioError@(IOError hn iot msg) -> let @@ -226,11 +249,12 @@ hClose :: Handle -> IO () hClose handle = readHandle handle >>= \ htype -> - writeHandle handle ClosedHandle >> case htype of ErrorHandle ioError -> + writeHandle handle htype >> fail ioError ClosedHandle -> + writeHandle handle htype >> ioe_closedHandle handle SemiClosedHandle fp (buf,_) -> (if buf /= ``NULL'' then @@ -245,19 +269,30 @@ hClose handle = has been performed, the ForeignObj embedded in the Handle is still lying around in the heap, so care is taken to avoid closing the file object when the ForeignObj - is finalised. (see freeFile()) -} + is finalised. -} if rc == 0 then - return () +#ifndef PAR + -- Mark the foreign object data value as gone to the finaliser (freeFile()) + writeForeignObj fp ``NULL'' `thenIO_Prim` \ () -> +#endif + writeHandle handle ClosedHandle else + writeHandle handle htype >> constructErrorAndFail "hClose" else - return () + writeHandle handle htype other -> - _ccall_ closeFile (filePtr other) `thenIO_Prim` \ rc -> + let fp = filePtr other in + _ccall_ closeFile fp `thenIO_Prim` \ rc -> if rc == 0 then - return () +#ifndef PAR + -- Mark the foreign object data + writeForeignObj fp ``NULL'' `thenIO_Prim` \ () -> +#endif + writeHandle handle ClosedHandle else + writeHandle handle htype >> constructErrorAndFail "hClose" \end{code} @@ -427,7 +462,11 @@ hSetBuffering handle mode = BlockBuffering Nothing -> -2 BlockBuffering (Just n) -> n +#ifndef PAR hcon :: Handle__ -> (ForeignObj -> (Maybe BufferMode) -> Bool -> Handle__) +#else + hcon :: Handle__ -> (Addr -> (Maybe BufferMode) -> Bool -> Handle__) +#endif hcon (ReadHandle _ _ _) = ReadHandle hcon (WriteHandle _ _ _) = WriteHandle hcon (AppendHandle _ _ _) = AppendHandle diff --git a/ghc/lib/glaExts/Foreign.lhs b/ghc/lib/glaExts/Foreign.lhs index 8273434390..81abc4f13d 100644 --- a/ghc/lib/glaExts/Foreign.lhs +++ b/ghc/lib/glaExts/Foreign.lhs @@ -79,12 +79,21 @@ instance CReturnable () -- Why, exactly? instance CCallable ForeignObj instance CCallable ForeignObj# -eqForeignObj :: ForeignObj -> ForeignObj -> Bool -makeForeignObj :: Addr -> Addr -> PrimIO ForeignObj +eqForeignObj :: ForeignObj -> ForeignObj -> Bool +makeForeignObj :: Addr -> Addr -> PrimIO ForeignObj +writeForeignObj :: ForeignObj -> Addr -> PrimIO () -makeForeignObj (A# obj) (A# finaliser) = ST $ \ (S# s#) -> +{- derived op - attaching a free() finaliser to a malloc() allocated reference. -} +makeMallocPtr :: Addr -> PrimIO ForeignObj + +makeForeignObj (A# obj) (A# finaliser) = ST ( \ (S# s#) -> case makeForeignObj# obj finaliser s# of - StateAndForeignObj# s1# fo# -> (ForeignObj fo#, S# s1#) + StateAndForeignObj# s1# fo# -> (ForeignObj fo#, S# s1#)) + +writeForeignObj (ForeignObj fo#) (A# datum#) = ST ( \ (S# s#) -> + case writeForeignObj# fo# datum# s# of { s1# -> ((), S# s1#) } ) + +makeMallocPtr a = makeForeignObj a (``&free''::Addr) eqForeignObj mp1 mp2 = unsafePerformPrimIO (_ccall_ eqForeignObj mp1 mp2) /= (0::Int) diff --git a/ghc/lib/required/Directory.lhs b/ghc/lib/required/Directory.lhs index e9f70e96d9..d7fdf7da88 100644 --- a/ghc/lib/required/Directory.lhs +++ b/ghc/lib/required/Directory.lhs @@ -1,8 +1,7 @@ % % (c) The AQUA Project, Glasgow University, 1994-1997 % - -\section[Directory]{Module @Directory@} +\section[Directory]{Directory interface} A directory contains a series of entries, each of which is a named reference to a file system object (file, directory etc.). Some @@ -18,23 +17,36 @@ some operating systems, it may also be possible to have paths which are relative to the current directory. \begin{code} -module Directory ( --- Permissions(Permissions), - createDirectory, removeDirectory, removeFile, - renameDirectory, renameFile, getDirectoryContents, - getCurrentDirectory, setCurrentDirectory -{- - ,doesFileExist, doesDirectoryExist, - getPermissions, setPermissions, +{-# OPTIONS -#include <sys/stat.h> #-} +module Directory + ( + Permissions(Permissions), + + createDirectory, + removeDirectory, + renameDirectory, + getDirectoryContents, + getCurrentDirectory, + setCurrentDirectory, + + removeFile, + renameFile, + + doesFileExist, + doesDirectoryExist, + getPermissions, + setPermissions, getModificationTime --} - ) where + ) where -import Prelude +import PrelBase import Foreign import IOBase -import STBase ( PrimIO ) -import PackedString ( packCBytesST, unpackPS ) +import STBase +import ArrBase +import PackedString ( packCBytesST, unpackPS, psToByteArrayST ) +import Time ( ClockTime(..) ) + \end{code} %********************************************************* @@ -52,6 +64,11 @@ renameFile :: FilePath -> FilePath -> IO () getDirectoryContents :: FilePath -> IO [FilePath] getCurrentDirectory :: IO FilePath setCurrentDirectory :: FilePath -> IO () +doesFileExist :: FilePath -> IO Bool +doesDirectoryExist :: FilePath -> IO Bool +getPermissions :: FilePath -> IO Permissions +setPermissions :: FilePath -> Permissions -> IO () +getModificationTime :: FilePath -> IO ClockTime \end{code} @@ -61,8 +78,9 @@ setCurrentDirectory :: FilePath -> IO () %* * %********************************************************* -The @Permissions@ type is used to record whether certain operations are permissible on a -file/directory: +The @Permissions@ type is used to record whether certain +operations are permissible on a file/directory: +[to whom? - owner/group/world - the Report don't say much] \begin{code} data Permissions @@ -70,7 +88,6 @@ data Permissions readable, writeable, executable, searchable :: Bool } deriving (Eq, Ord, Read, Show) - \end{code} %********************************************************* @@ -410,25 +427,26 @@ setCurrentDirectory path = \begin{code} -{- -doesFileExist :: FilePath -> IO Bool +--doesFileExist :: FilePath -> IO Bool doesFileExist name = psToByteArrayST name `thenIO_Prim` \ path -> _ccall_ access path (``F_OK''::Int) `thenIO_Prim` \ rc -> return (rc == 0) -doesDirectoryExist :: FilePath -> IO Bool -doesDirectoryExist name = - (getFileStatus >>= isDirectory) `catch` (\ _ -> return False) +--doesDirectoryExist :: FilePath -> IO Bool +doesDirectoryExist name = + (getFileStatus name >>= \ st -> return (isDirectory st)) + `catch` + (\ _ -> return False) -getModificationTime :: FilePath -> IO Bool +--getModificationTime :: FilePath -> IO ClockTime getModificationTime name = - getFileStatus >>= \ st -> - return (modificationTime st) + getFileStatus name >>= \ st -> + modificationTime st -getPermissions :: FilePath -> IO Permissions +--getPermissions :: FilePath -> IO Permissions getPermissions name = - getFileStatus >>= \ st -> + getFileStatus name >>= \ st -> let fm = fileMode st isect v = intersectFileMode v fm == v @@ -441,5 +459,99 @@ getPermissions name = searchable = not (isRegularFile st) && isect ownerExecuteMode } ) --} + +--setPermissions :: FilePath -> Permissions -> IO () +setPermissions name (Permissions r w e s) = + let + read# = case (if r then ownerReadMode else ``0'') of { W# x# -> x# } + write# = case (if w then ownerWriteMode else ``0'') of { W# x# -> x# } + exec# = case (if e || s then ownerExecuteMode else ``0'') of { W# x# -> x# } + + mode = I# (word2Int# (read# `or#` write# `or#` exec#)) + in + psToByteArrayST name `thenIO_Prim` \ path -> + _ccall_ chmod path mode `thenIO_Prim` \ rc -> + if rc == 0 then + return () + else + fail (IOError Nothing SystemError "Directory.setPermissions") + +\end{code} + + +(Sigh)..copied from Posix.Files to avoid dep. on posix library + +\begin{code} +type FileStatus = ByteArray Int + +getFileStatus :: FilePath -> IO FileStatus +getFileStatus name = + psToByteArrayST name `thenIO_Prim` \ path -> + newCharArray (0,``sizeof(struct stat)'') `thenIO_Prim` \ bytes -> + _casm_ ``%r = stat(%0,(struct stat *)%1);'' path bytes + `thenIO_Prim` \ rc -> + if rc == 0 then + unsafeFreezeByteArray bytes `thenIO_Prim` \ stat -> + return stat + else + fail (IOError Nothing SystemError "Directory.getFileStatus") + +modificationTime :: FileStatus -> IO ClockTime +modificationTime stat = + malloc1 `thenIO_Prim` \ i1 -> + _casm_ ``((unsigned long *)%1)[0] = ((struct stat *)%0)->st_mtime;'' stat i1 `thenIO_Prim` \ () -> + cvtUnsigned i1 `thenIO_Prim` \ secs -> + return (TOD secs 0) + where + malloc1 = ST $ \ (S# s#) -> + case newIntArray# 1# s# of + StateAndMutableByteArray# s2# barr# -> (MutableByteArray bnds barr#, S# s2#) + + bnds = (0,1) + -- The C routine fills in an unsigned word. We don't have `unsigned2Integer#,' + -- so we freeze the data bits and use them for an MP_INT structure. Note that + -- zero is still handled specially, although (J# 1# 1# (ptr to 0#)) is probably + -- acceptable to gmp. + + cvtUnsigned (MutableByteArray _ arr#) = ST $ \ (S# s#) -> + case readIntArray# arr# 0# s# of + StateAndInt# s2# r# -> + if r# ==# 0# then + (0, S# s2#) + else + case unsafeFreezeByteArray# arr# s2# of + StateAndByteArray# s3# frozen# -> (J# 1# 1# frozen#, S# s3#) + +isDirectory :: FileStatus -> Bool +isDirectory stat = unsafePerformPrimIO $ + _casm_ ``%r = S_ISDIR(((struct stat *)%0)->st_mode);'' stat >>= \ rc -> + return (rc /= 0) + +isRegularFile :: FileStatus -> Bool +isRegularFile stat = unsafePerformPrimIO $ + _casm_ ``%r = S_ISREG(((struct stat *)%0)->st_mode);'' stat >>= \ rc -> + return (rc /= 0) + + +\end{code} + +\begin{code} +type FileMode = Word +ownerReadMode :: FileMode +ownerReadMode = ``S_IRUSR'' + +ownerWriteMode :: FileMode +ownerWriteMode = ``S_IWUSR'' + +ownerExecuteMode :: FileMode +ownerExecuteMode = ``S_IXUSR'' + +intersectFileMode :: FileMode -> FileMode -> FileMode +intersectFileMode (W# m1#) (W# m2#) = W# (m1# `and#` m2#) + +fileMode :: FileStatus -> FileMode +fileMode stat = unsafePerformPrimIO $ + _casm_ ``%r = ((struct stat *)%0)->st_mode;'' stat >>= \ mode -> + return mode + \end{code} diff --git a/ghc/lib/required/IO.lhs b/ghc/lib/required/IO.lhs index 34d5a338e6..c727c0082c 100644 --- a/ghc/lib/required/IO.lhs +++ b/ghc/lib/required/IO.lhs @@ -39,7 +39,7 @@ import IOHandle -- much of the real stuff is in here import PackedString ( nilPS, packCBytesST, unpackPS ) import PrelBase import GHC -import Foreign ( makeForeignObj ) +import Foreign ( makeForeignObj, writeForeignObj ) \end{code} %********************************************************* @@ -289,11 +289,14 @@ lazyReadBlock handle = then return nilPS else packCBytesST bytes buf) >>= \ some -> if bytes < 0 then - makeForeignObj ``NULL'' ``&freeFile'' >>= \ null_fp -> - ioToST (writeHandle handle (SemiClosedHandle null_fp (``NULL'', 0))) - >> _ccall_ free buf >>= \ () -> _ccall_ closeFile fp >> +#ifndef PAR + writeForeignObj fp ``NULL'' >> + ioToST (writeHandle handle (SemiClosedHandle fp (``NULL'', 0))) >> +#else + ioToST (writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))) >> +#endif returnPrimIO (unpackPS some) else ioToST (writeHandle handle htype) >> @@ -314,11 +317,14 @@ lazyReadLine handle = then return nilPS else packCBytesST bytes buf) >>= \ some -> if bytes < 0 then - makeForeignObj ``NULL'' ``&freeFile'' >>= \ null_fp -> - ioToST (writeHandle handle (SemiClosedHandle null_fp (``NULL'', 0))) - >> _ccall_ free buf >>= \ () -> _ccall_ closeFile fp >> +#ifndef PAR + writeForeignObj fp ``NULL'' >> + ioToST (writeHandle handle (SemiClosedHandle fp (``NULL'', 0))) >> +#else + ioToST (writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))) >> +#endif returnPrimIO (unpackPS some) else ioToST (writeHandle handle htype) >> @@ -336,10 +342,13 @@ lazyReadChar handle = SemiClosedHandle fp buf_info -> _ccall_ readChar fp >>= \ char -> if char == ``EOF'' then - makeForeignObj ``NULL'' ``&freeFile'' >>= \ null_fp -> - ioToST (writeHandle handle (SemiClosedHandle null_fp buf_info)) - >> _ccall_ closeFile fp >> +#ifndef PAR + writeForeignObj fp ``NULL'' >> + ioToST (writeHandle handle (SemiClosedHandle fp (``NULL'', 0))) >> +#else + ioToST (writeHandle handle (SemiClosedHandle ``NULL'' (``NULL'', 0))) >> +#endif returnPrimIO "" else ioToST (writeHandle handle htype) >> @@ -425,10 +434,18 @@ hPutStr handle str = else constructErrorAndFail "hPutStr" where +#ifndef PAR writeLines :: ForeignObj -> String -> PrimIO Bool +#else + writeLines :: Addr -> String -> PrimIO Bool +#endif writeLines = writeChunks ``BUFSIZ'' True +#ifndef PAR writeBlocks :: ForeignObj -> Int -> String -> PrimIO Bool +#else + writeBlocks :: Addr -> Int -> String -> PrimIO Bool +#endif writeBlocks fp size s = writeChunks size False fp s {- @@ -443,8 +460,11 @@ hPutStr handle str = a whole lot quicker. -- SOF 3/96 -} +#ifndef PAR writeChunks :: Int -> Bool -> ForeignObj -> String -> PrimIO Bool - +#else + writeChunks :: Int -> Bool -> Addr -> String -> PrimIO Bool +#endif writeChunks (I# bufLen) chopOnNewLine fp s = newCharArray (0,I# bufLen) >>= \ arr@(MutableByteArray _ arr#) -> let @@ -478,7 +498,11 @@ hPutStr handle str = in shoveString 0# s +#ifndef PAR writeChars :: ForeignObj -> String -> PrimIO Bool +#else + writeChars :: Addr -> String -> PrimIO Bool +#endif writeChars fp "" = returnPrimIO True writeChars fp (c:cs) = _ccall_ filePutc fp (ord c) >>= \ rc -> diff --git a/ghc/lib/required/Time.lhs b/ghc/lib/required/Time.lhs index 881166d8c9..0c172e9ee1 100644 --- a/ghc/lib/required/Time.lhs +++ b/ghc/lib/required/Time.lhs @@ -9,6 +9,8 @@ clock times, including timezone information (i.e, the functionality of its use of Coordinated Universal Time (UTC). \begin{code} +{-# OPTIONS -#include "cbits/timezone.h" -#include "cbits/stgio.h" #-} + module Time ( CalendarTime(..), @@ -16,20 +18,23 @@ module Time Day, CalendarTime(CalendarTime), TimeDiff(TimeDiff), - ClockTime, + ClockTime(..), -- non-standard, lib. report gives this as abstract getClockTime, addToClockTime, diffClockTimes, toCalendarTime, toUTCTime, toClockTime, - calendarToTimeString, formatCalendarTime + calendarTimeToString, formatCalendarTime ) where import PrelBase import ST -import IOBase ( IOError(..), constructErrorAndFail ) +import IOBase import ArrBase import STBase - +import ST +import Ix +import Char (intToDigit) import PackedString (unpackPS, packCBytesST) -import PosixUtil (allocWords, allocChars) +import Locale + \end{code} One way to partition and give name to chunks of a year and a week: @@ -53,8 +58,7 @@ Clock times may be compared, converted to strings, or converted to an external calendar time @CalendarTime@. \begin{code} -data ClockTime = TOD Integer Integer - deriving (Eq, Ord) +data ClockTime = TOD Integer Integer deriving (Eq, Ord) \end{code} When a @ClockTime@ is shown, it is converted to a string of the form @@ -244,7 +248,7 @@ toCalendarTime (TOD sec@(J# a# s# d#) psec) = unsafePerformPrimIO $ _ccall_ strlen zone >>= \ len -> packCBytesST len zone >>= \ tzname -> returnPrimIO (CalendarTime (1900+year) mon mday hour min sec psec - wday yday (unpackPS tzname) tz (isdst /= 0)) + (toEnum wday) yday (unpackPS tzname) tz (isdst /= 0)) toUTCTime :: ClockTime -> CalendarTime toUTCTime (TOD sec@(J# a# s# d#) psec) = unsafePerformPrimIO ( @@ -265,7 +269,7 @@ toUTCTime (TOD sec@(J# a# s# d#) psec) = unsafePerformPrimIO ( _casm_ ``%r = ((struct tm *)%0)->tm_wday;'' tm >>= \ wday -> _casm_ ``%r = ((struct tm *)%0)->tm_yday;'' tm >>= \ yday -> returnPrimIO (CalendarTime (1900+year) mon mday hour min sec psec - wday yday "UTC" 0 False) + (toEnum wday) yday "UTC" 0 False) ) toClockTime :: CalendarTime -> ClockTime @@ -287,79 +291,93 @@ toClockTime (CalendarTime year mon mday hour min sec psec wday yday tzname tz is bottom :: (Int,Int) bottom = error "Time.bottom" + + +-- (copied from PosixUtil, for now) +-- Allocate a mutable array of characters with no indices. + +allocChars :: Int -> ST s (MutableByteArray s ()) +allocChars (I# size#) = ST $ \ (S# s#) -> + case newCharArray# size# s# of + StateAndMutableByteArray# s2# barr# -> (MutableByteArray bot barr#, S# s2#) + where + bot = error "Time.allocChars" + +-- Allocate a mutable array of words with no indices + +allocWords :: Int -> ST s (MutableByteArray s ()) +allocWords (I# size#) = ST $ \ (S# s#) -> + case newIntArray# size# s# of + StateAndMutableByteArray# s2# barr# -> (MutableByteArray bot barr#, S# s2#) + where + bot = error "Time.allocWords" + \end{code} \begin{code} -calendarTimeToString :: CalendarTime -> String -calendarTimeToString = formatCalendarTime defaultTimeLocale "%c" - -formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String -formatCalendarTime l - fmt - ct@(CalendarTime - year mon - day hour - min sec - sdec - wday yday tzname _ _) - = doFmt fmt - where - doFmt ('%':c:cs) = decode c ++ doFmt cs - doFmt (c:cs) = c : doFmt cs - doFmt "" = "" - - to12 h = let h' = h `mod` 12 in if h == 0 then 12 else h - - decode 'A' = fst (wdays l !! fromEnum wday) - decode 'a' = snd (wdays l !! fromEnum wday) - decode 'B' = fst (months l !! fromEnum mon) - decode 'b' = snd (months l !! fromEnum mon) - decode 'h' = snd (months l !! fromEnum mon) - decode 'C' = show2 (year `quot` 100) - decode 'c' = doFmt (dateTimeFmt l) - decode 'D' = doFmt "%m/%d/%y" - decode 'd' = show2 day - decode 'e' = show2' day - decode 'H' = show2 hour - decode 'I' = show2 (to12 hour) - decode 'j' = show3 yday - decode 'k' = show2' hour - decode 'l' = show2' (to12 hour) - decode 'M' = show2 min - decode 'm' = show2 (fromEnum mon+1) - decode 'n' = "\n" - decode 'p' = (if hour < 12 then fst else snd) (amPm l) - decode 'R' = doFmt "%H:%M" - decode 'r' = doFmt (time12Fmt l) - decode 'T' = doFmt "%H:%M:%S" - decode 't' = "\t" - decode 'S' = show2 sec - decode 's' = show2 sec -- Implementation-dependent, sez the lib doc.. - decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) - decode 'u' = show (let n = fromEnum wday in if n == 0 then 7 else n) - decode 'V' = - let (week, days) = - (yday + 7 - if fromEnum wday > 0 then - fromEnum wday - 1 else 6) `divMod` 7 - in - show2 (if days >= 4 - then week+1 - else if week == 0 then 53 else week) - decode 'W' = - show2 ((yday + 7 - if fromEnum wday > 0 then - fromEnum wday - 1 else 6) `div` 7) - decode 'w' = show (fromEnum wday) - decode 'X' = doFmt (timeFmt l) - decode 'x' = doFmt (dateFmt l) - decode 'Y' = show year - decode 'y' = show2 (year `rem` 100) - decode 'Z' = tzname - decode '%' = "%" - decode c = [c] - -show2, show2', show3 :: Int -> String -show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)] -show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x -show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100) - +calendarTimeToString :: CalendarTime -> String +calendarTimeToString = formatCalendarTime defaultTimeLocale "%c" + +formatCalendarTime :: TimeLocale -> String -> CalendarTime -> String +formatCalendarTime l fmt ct@(CalendarTime year mon day hour min sec sdec + wday yday tzname _ _) = + doFmt fmt + where doFmt ('%':c:cs) = decode c ++ doFmt cs + doFmt (c:cs) = c : doFmt cs + doFmt "" = "" + to12 h = let h' = h `mod` 12 in if h == 0 then 12 else h + decode 'A' = fst (wDays l !! fromEnum wday) + decode 'a' = snd (wDays l !! fromEnum wday) + decode 'B' = fst (months l !! fromEnum mon) + decode 'b' = snd (months l !! fromEnum mon) + decode 'h' = snd (months l !! fromEnum mon) + decode 'C' = show2 (year `quot` 100) + decode 'c' = doFmt (dateTimeFmt l) + decode 'D' = doFmt "%m/%d/%y" + decode 'd' = show2 day + decode 'e' = show2' day + decode 'H' = show2 hour + decode 'I' = show2 (to12 hour) + decode 'j' = show3 yday + decode 'k' = show2' hour + decode 'l' = show2' (to12 hour) + decode 'M' = show2 min + decode 'm' = show2 (fromEnum mon+1) + decode 'n' = "\n" + decode 'p' = (if hour < 12 then fst else snd) (amPm l) + decode 'R' = doFmt "%H:%M" + decode 'r' = doFmt (time12Fmt l) + decode 'T' = doFmt "%H:%M:%S" + decode 't' = "\t" + decode 'S' = show2 sec + decode 's' = show2 sec -- Implementation-dependent, sez the lib doc.. + decode 'U' = show2 ((yday + 7 - fromEnum wday) `div` 7) + decode 'u' = show (let n = fromEnum wday in + if n == 0 then 7 else n) + decode 'V' = + let (week, days) = + (yday + 7 - if fromEnum wday > 0 then + fromEnum wday - 1 else 6) `divMod` 7 + in show2 (if days >= 4 then + week+1 + else if week == 0 then 53 else week) + + decode 'W' = + show2 ((yday + 7 - if fromEnum wday > 0 then + fromEnum wday - 1 else 6) `div` 7) + decode 'w' = show (fromEnum wday) + decode 'X' = doFmt (timeFmt l) + decode 'x' = doFmt (dateFmt l) + decode 'Y' = show year + decode 'y' = show2 (year `rem` 100) + decode 'Z' = tzname + decode '%' = "%" + decode c = [c] + +show2, show2', show3 :: Int -> String +show2 x = [intToDigit (x `quot` 10), intToDigit (x `rem` 10)] + +show2' x = if x < 10 then [ ' ', intToDigit x] else show2 x + +show3 x = intToDigit (x `quot` 100) : show2 (x `rem` 100) \end{code} diff --git a/ghc/mk/boilerplate.mk b/ghc/mk/boilerplate.mk index 96782a0a79..08e36c90b8 100644 --- a/ghc/mk/boilerplate.mk +++ b/ghc/mk/boilerplate.mk @@ -24,11 +24,9 @@ TOP:=$(GHC_TOP) # ----------------------------------------------------------------- # Everything after this point # augments or overrides previously set variables. -# (these files are optional, so `make' won't fret if -# cannot get to them). # ----------------------------------------------------------------- --include $(TOP)/mk/paths.mk --include $(TOP)/mk/opts.mk +include $(TOP)/mk/paths.mk +include $(TOP)/mk/opts.mk include $(TOP)/mk/suffix.mk diff --git a/ghc/mk/paths.mk b/ghc/mk/paths.mk index d7b30e7ae5..635956a0c1 100644 --- a/ghc/mk/paths.mk +++ b/ghc/mk/paths.mk @@ -10,9 +10,13 @@ HaskellCompilerType = $(WithGhcHcType) # What ways to build the RTS+libs WAYS=$(GhcLibWays) +GCap=-optc-DGCap +#GC2s=-optc-DGC2s +#GC1s=-optc-DGC1s MKDEPENDHSSRC = $(GHC_UTILS_DIR)/mkdependHS UNLIT = $(GHC_UNLIT_DIR)/unlit +GHC_UNLIT = $(GHC_UNLIT_DIR)/unlit GHC_UNLIT_DIR = $(GHC_UTILS_DIR)/unlit #----------------------------------------------------------------------------- @@ -29,10 +33,10 @@ endif # Ugen ifdef UseInstalledUtils -UGEN = ugen +UGEN = ugen else UGEN = $(UGEN_DIR)/ugen -UGENSRC = $(GHC_UTILS_DIR)/ugen +UGEN_DIR = $(GHC_UTILS_DIR)/ugen endif #----------------------------------------------------------------------------- diff --git a/ghc/runtime/Makefile b/ghc/runtime/Makefile index ff991b0082..b5713a4859 100644 --- a/ghc/runtime/Makefile +++ b/ghc/runtime/Makefile @@ -1,5 +1,5 @@ #----------------------------------------------------------------------------- -# $Id: Makefile,v 1.4 1997/03/14 05:11:52 sof Exp $ +# $Id: Makefile,v 1.5 1997/03/17 20:34:59 simonpj Exp $ # This is the Makefile for the runtime-system stuff. # This stuff is written in C (and cannot be written in Haskell). @@ -159,9 +159,9 @@ LIBOBJS = $(patsubst %.lc,%.$(way_)o,$(SRCS_RTS_LC)) \ # # dependencies # -SRC_HC_OPTS += -I$(GHC_INCLUDE_DIR) -O -optc-DIN_GHC_RTS=1 -I$(GHC_RUNTIME_DIR)/storage +SRC_HC_OPTS += -I$(GHC_INCLUDE_DIR) $(GCap) $(GC2s) $(GC1s) -O -optc-DIN_GHC_RTS=1 -I$(GHC_RUNTIME_DIR)/storage -SRC_MKDEPENDC_OPTS += $(GCap) $(GC2s) $(GC1s) +SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR) $(GCap) $(GC2s) $(GC1s) #----------------------------------------------------------------------------- # file-specific options diff --git a/ghc/runtime/prims/PrimMisc.lc b/ghc/runtime/prims/PrimMisc.lc index 953ed15b12..021e0aa736 100644 --- a/ghc/runtime/prims/PrimMisc.lc +++ b/ghc/runtime/prims/PrimMisc.lc @@ -43,6 +43,8 @@ stg_exit (n) /* can't call regular "exit" from Haskell because it has no return value */ I_ n; { + /* Storage manager shutdown */ + shutdownHaskell(); EXIT(n); return(0); /* GCC warning food */ } |