diff options
26 files changed, 1087 insertions, 712 deletions
diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 070cc7e380..cc5967df18 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -60,7 +60,12 @@ call to a cost evaluation function @GRAN_EXEC@. For that, \begin{code} writeRealC :: Handle -> AbstractC -> IO () -writeRealC handle absC = printForC handle (pprAbsC absC (costs absC)) +--writeRealC handle absC = +-- _scc_ "writeRealC" +-- printDoc LeftMode handle (pprAbsC absC (costs absC)) +writeRealC handle absC = + _scc_ "writeRealC" + printForC handle (pprAbsC absC (costs absC)) dumpRealC :: AbstractC -> SDoc dumpRealC absC = pprAbsC absC (costs absC) @@ -77,19 +82,16 @@ emitMacro (Cost (i,b,l,s,f)) = hcat [ ptext SLIT("GRAN_EXEC"), char '(', int i, comma, int b, comma, int l, comma, int s, comma, int f, pp_paren_semi ] -\end{code} -\begin{code} pp_paren_semi = text ");" +\end{code} --- --------------------------------------------------------------------------- --- New type: Now pprAbsC also takes the costs for evaluating the Abstract C --- code as an argument (that's needed when spitting out the GRAN_EXEC macro --- which must be done before the return i.e. inside absC code) HWL --- --------------------------------------------------------------------------- +New type: Now pprAbsC also takes the costs for evaluating the Abstract C +code as an argument (that's needed when spitting out the GRAN_EXEC macro +which must be done before the return i.e. inside absC code) HWL +\begin{code} pprAbsC :: AbstractC -> CostRes -> SDoc - pprAbsC AbsCNop _ = empty pprAbsC (AbsCStmts s1 s2) c = ($$) (pprAbsC s1 c) (pprAbsC s2 c) @@ -97,7 +99,6 @@ pprAbsC (CClosureUpdInfo info) c = pprAbsC info c pprAbsC (CAssign dest src) _ = pprAssign (getAmodeRep dest) dest src - pprAbsC (CJump target) c = ($$) (hcat [emitMacro c {-WDP:, text "/* <--++ CJump */"-} ]) (hcat [ text jmp_lit, pprAmode target, pp_paren_semi ]) @@ -199,9 +200,9 @@ pprAbsC stmt@(COpStmt results op args liveness_mask vol_regs) _ case (ppr_vol_regs vol_regs) of { (pp_saves, pp_restores) -> if primOpNeedsWrapper op then vcat [ pp_saves, - the_op, - pp_restores - ] + the_op, + pp_restores + ] else the_op } @@ -498,7 +499,6 @@ if_profiling pretty = if opt_SccProfilingOn then pretty else char '0' -- leave it out! - -- --------------------------------------------------------------------------- -- Changes for GrAnSim: -- draw costs for computation in head of if into both branches; @@ -561,8 +561,8 @@ Some rough notes on generating code for @CCallOp@: (This happens after restoration of essential registers because we might need the @Base@ register to access all the others correctly.) -{- Doesn't apply anymore with ForeignObj, structure create via primop. - makeForeignObj (ForeignObj is not CReturnable) +{- Doesn't apply anymore with ForeignObj, structure created via the primop. + makeForeignObj (i.e., ForeignObj is not CReturnable) 7) If returning Malloc Pointer, build a closure containing the appropriate value. -} @@ -708,7 +708,7 @@ For l-values, the critical questions are: \begin{code} ppr_casm_results :: [CAddrMode] -- list of results (length <= 1) - -> SDoc -- liveness mask + -> SDoc -- liveness mask -> ( SDoc, -- declaration of any local vars [SDoc], -- list of result vars (same length as results) @@ -1138,6 +1138,7 @@ type CLabelSet = FiniteMap CLabel (){-any type will do-} emptyCLabelSet = emptyFM x `elementOfCLabelSet` labs = case (lookupFM labs x) of { Just _ -> True; Nothing -> False } + addToCLabelSet set x = addToFM set x () type TEenv = (UniqSet Unique, CLabelSet) diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index bb968a3e23..414ef2e663 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -258,15 +258,16 @@ mkRecordSelId field_label selector_ty [data_id] = mkTemplateLocals [data_ty] alts = map mk_maybe_alt data_cons + the_alts = catMaybes alts + sel_rhs = mkTyLam tyvars $ mkValLam [data_id] $ Case (Var data_id) -- if any of the constructors don't have the label, ... (if any (not . isJust) alts then - AlgAlts (catMaybes alts) - (BindDefault data_id error_expr) + AlgAlts the_alts(BindDefault data_id error_expr) else - AlgAlts (catMaybes alts) NoDefault) + AlgAlts the_alts NoDefault) mk_maybe_alt data_con = case maybe_the_arg_id of diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 22a8556fb4..2a79917cf8 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -43,6 +43,7 @@ module Unique ( andandIdKey, appendIdKey, arrayPrimTyConKey, + assertIdKey, augmentIdKey, boolTyConKey, boundedClassKey, @@ -708,4 +709,5 @@ toEnumClassOpKey = mkPreludeMiscIdUnique 68 \begin{code} inlineIdKey = mkPreludeMiscIdUnique 69 coerceIdKey = mkPreludeMiscIdUnique 70 +assertIdKey = mkPreludeMiscIdUnique 71 \end{code} diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 2eccc3e3e7..1d4edf00ee 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -502,13 +502,14 @@ constraints. simplify_eqns :: [EquationInfo] -> [EquationInfo] simplify_eqns [] = [] simplify_eqns ((EqnInfo n ctx pats result):qs) = - (EqnInfo n ctx(map simplify_pat pats) result) : - simplify_eqns qs + (EqnInfo n ctx pats' result) : simplify_eqns qs + where + pats' = map simplify_pat pats simplify_pat :: TypecheckedPat -> TypecheckedPat -simplify_pat (WildPat gt ) = WildPat gt -simplify_pat (VarPat id) = WildPat (idType id) +simplify_pat pat@(WildPat gt) = pat +simplify_pat (VarPat id) = WildPat (idType id) simplify_pat (LazyPat p) = simplify_pat p @@ -535,11 +536,11 @@ simplify_pat (RecPat id ty idps) = ConPat id ty pats pats = map (\ (id,p,_)-> simplify_pat p) idps simplify_pat pat@(LitPat lit lit_ty) - | isUnboxedType lit_ty = LitPat lit lit_ty + | isUnboxedType lit_ty = pat | lit_ty == charTy = ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy] - | otherwise = pprPanic "tidy1:LitPat:" (ppr pat) + | otherwise = pat --pprPanic "tidy1:LitPat:" (ppr pat) where mk_char (HsChar c) = HsCharPrim c @@ -554,13 +555,20 @@ simplify_pat (NPat lit lit_ty hsexpr) = better_pat | lit_ty == doubleTy = ConPat doubleDataCon lit_ty [LitPat (mk_double lit) doublePrimTy] -- Convert the literal pattern "" to the constructor pattern []. - | null_str_lit lit = ConPat nilDataCon lit_ty [] + | null_str_lit lit = ConPat nilDataCon lit_ty [] + | one_str_lit lit = ConPat consDataCon list_ty + [ ConPat charDataCon lit_ty [LitPat (mk_head_char lit) charPrimTy] + , ConPat nilDataCon lit_ty []] | otherwise = NPat lit lit_ty hsexpr + list_ty = mkListTy lit_ty + mk_int (HsInt i) = HsIntPrim i mk_int l@(HsLitLit s) = l + mk_head_char (HsString s) = HsCharPrim (_HEAD_ s) + mk_char (HsChar c) = HsCharPrim c mk_char l@(HsLitLit s) = l @@ -579,6 +587,9 @@ simplify_pat (NPat lit lit_ty hsexpr) = better_pat null_str_lit (HsString s) = _NULL_ s null_str_lit other_lit = False + one_str_lit (HsString s) = _LENGTH_ s == (1::Int) + one_str_lit other_lit = False + simplify_pat (NPlusKPat id hslit ty hsexpr1 hsexpr2) = --NPlusKPat id hslit ty hsexpr1 hsexpr2 WildPat ty where ty = panic "Check.simplify_pat: Never used" diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index d7c3bdb4c1..a147fbfaa5 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -499,7 +499,9 @@ tidy1 v pat@(LitPat lit lit_ty) match_result = returnDs (ConPat charDataCon charTy [LitPat (mk_char lit) charPrimTy], match_result) - | otherwise = pprPanic "tidy1:LitPat:" (ppr pat) + | otherwise + --= pprPanic "tidy1:LitPat:" (ppr pat) + = returnDs (pat, match_result) where mk_char (HsChar c) = HsCharPrim c diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index 4d16d00e43..5017e6cfe5 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -21,6 +21,7 @@ import DsMonad import DsUtils import Literal ( mkMachInt, Literal(..) ) +import PrimRep ( PrimRep(IntRep) ) import Maybes ( catMaybes ) import Type ( Type, isUnpointedType ) import Util ( panic, assertPanic ) @@ -72,8 +73,8 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (LitPat literal lit_t mk_core_lit ty (HsStringPrim s) = MachStr s mk_core_lit ty (HsFloatPrim f) = MachFloat f mk_core_lit ty (HsDoublePrim d) = MachDouble d - mk_core_lit ty (HsLitLit s) = ASSERT(isUnpointedType ty) - MachLitLit s (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???") + mk_core_lit ty (HsLitLit s) = --ASSERT(isUnpointedType ty) + MachLitLit s IntRep -- (panic "MatchLit.matchLiterals:mk_core_lit:HsLitLit; typePrimRep???") mk_core_lit ty other = panic "matchLiterals:mk_core_lit:unhandled" \end{code} diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 995a71975f..471b3c1d69 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -310,6 +310,7 @@ opt_IgnoreIfacePragmas = lookUp SLIT("-fignore-interface-pragmas") opt_IrrefutableTuples = lookUp SLIT("-firrefutable-tuples") opt_MultiParamClasses = opt_GlasgowExts opt_NoImplicitPrelude = lookUp SLIT("-fno-implicit-prelude") +opt_NoHiCheck = lookUp SLIT("-fno-hi-version-check") opt_NumbersStrict = lookUp SLIT("-fnumbers-strict") opt_OmitBlackHoling = lookUp SLIT("-dno-black-holing") opt_OmitInterfacePragmas = lookUp SLIT("-fomit-interface-pragmas") diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs index 16b84fefb2..106fe29c6f 100644 --- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs +++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs @@ -24,6 +24,7 @@ import Stix ( StixTree ) import Unique ( mkBuiltinUnique ) import Util ( mapAccumB, panic ) import GlaExts ( trace ) +import Outputable \end{code} This is the generic register allocator. @@ -77,16 +78,18 @@ simpleRegAlloc simpleRegAlloc _ _ _ [] = Just [] simpleRegAlloc free live env (instr:instrs) - = if null deadSrcs && maybeToBool newAlloc && maybeToBool instrs2 then - Just (instr3 : instrs3) - else - Nothing + | null deadSrcs && + maybeToBool newAlloc && + maybeToBool instrs2 + = Just (instr3 : instrs3) + | otherwise + = Nothing where instr3 = patchRegs instr (lookup env2) - (srcs, dsts) = case regUsage instr of { RU s d -> (regSetToList s, regSetToList d) } + (srcs, dsts) = case regUsage instr of (RU s d) -> (regSetToList s, regSetToList d) - lookup env x = case lookupFM env x of {Just y -> y; Nothing -> x} + lookup env x = case lookupFM env x of Just y -> y; Nothing -> x deadSrcs = [r | r@(UnmappedReg _ _) <- srcs, lookup env r `not_elem` live] newDsts = [r | r@(UnmappedReg _ _) <- dsts, r `not_elem` keysFM env] @@ -108,14 +111,14 @@ simpleRegAlloc free live env (instr:instrs) allocateNewReg _ Nothing = Nothing - allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs)) = - if null choices then Nothing - else Just (free2, prs2) + allocateNewReg d@(UnmappedReg _ pk) (Just (free, prs)) + | null choices = Nothing + | otherwise = Just (free2, prs2) where choices = possibleMRegs pk free - reg = head choices - free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} ) - prs2 = ((d, MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs) + reg = head choices + free2 = free `useMReg` (case reg of {IBOX(reg2) -> reg2} ) + prs2 = ((d, MappedReg (case reg of {IBOX(reg2) -> reg2})) : prs) \end{code} Here is the ``clever'' bit. First go backward (i.e. left), looking for @@ -129,15 +132,20 @@ hairyRegAlloc -> [Instr] -> [Instr] -hairyRegAlloc regs reserve_regs instrs - = case mapAccumB (doRegAlloc reserve_regs) - (RH regs' 1 emptyFM) noFuture instrs - of (RH _ loc' _, _, instrs') -> - if loc' == 1 then instrs' else - case mapAccumB do_RegAlloc_Nil - (RH regs'' loc' emptyFM) noFuture (flattenOrdList (patchMem instrs')) - of ((RH _ loc'' _),_,instrs'') -> - if loc'' == loc' then instrs'' else panic "runRegAllocate" +hairyRegAlloc regs reserve_regs instrs = + case mapAccumB (doRegAlloc reserve_regs) (RH regs' 1 emptyFM) noFuture instrs of + (RH _ mloc1 _, _, instrs') + | mloc1 == 1 -> instrs' + | otherwise -> + let + instrs_patched' = patchMem instrs' + instrs_patched = flattenOrdList instrs_patched' + in + case mapAccumB do_RegAlloc_Nil (RH regs'' mloc1 emptyFM) noFuture instrs_patched of + ((RH _ mloc2 _),_,instrs'') + | mloc2 == mloc1 -> instrs'' + | otherwise -> instrs'' + --pprPanic "runRegAllocate" (ppr mloc2 <+> ppr mloc1) where regs' = regs `useMRegs` reserve_regs regs'' = mkMRegsState reserve_regs @@ -169,11 +177,12 @@ patchMem cs = foldr (mkSeqList . patchMem') mkEmptyList cs patchMem' :: Instr -> InstrList patchMem' instr - = if null memSrcs && null memDsts then mkUnitList instr - else mkSeqList - (foldr mkParList mkEmptyList loadSrcs) - (mkSeqList instr' - (foldr mkParList mkEmptyList spillDsts)) + | null memSrcs && null memDsts = mkUnitList instr + | otherwise = + mkSeqList + (foldr mkParList mkEmptyList loadSrcs) + (mkSeqList instr' + (foldr mkParList mkEmptyList spillDsts)) where (RU srcs dsts) = regUsage instr @@ -221,18 +230,26 @@ getUsage (RF next_in_use future reg_conflicts) instr live_through = in_use `minusRegSet` dsts last_used = [ r | r <- regSetToList srcs, not (r `elementOfRegSet` (fstFL future) || r `elementOfRegSet` in_use)] + in_use' = srcs `unionRegSets` live_through - reg_conflicts' = case new_conflicts of - [] -> reg_conflicts - _ -> addListToFM reg_conflicts new_conflicts - new_conflicts = if isEmptyRegSet live_dynamics then [] - else [ (r, merge_conflicts r) - | r <- extractMappedRegNos (regSetToList dsts) ] - merge_conflicts reg = case lookupFM reg_conflicts reg of - Nothing -> live_dynamics - Just conflicts -> conflicts `unionRegSets` live_dynamics - live_dynamics = mkRegSet - [ r | r@(UnmappedReg _ _) <- regSetToList live_through ] + + reg_conflicts' = + case new_conflicts of + [] -> reg_conflicts + _ -> addListToFM reg_conflicts new_conflicts + + new_conflicts + | isEmptyRegSet live_dynamics = [] + | otherwise = + [ (r, merge_conflicts r) + | r <- extractMappedRegNos (regSetToList dsts) ] + + merge_conflicts reg = + case lookupFM reg_conflicts reg of + Nothing -> live_dynamics + Just conflicts -> conflicts `unionRegSets` live_dynamics + + live_dynamics = mkRegSet [ r | r@(UnmappedReg _ _) <- regSetToList live_through ] doRegAlloc' :: [RegNo] @@ -273,18 +290,23 @@ doRegAlloc' reserved (RH frs loc env) (RI in_use srcs dsts lastu conflicts) inst Nothing -> trace "Lost register; possibly a floating point type error in a _ccall_?" dyn dynToStatic other = other - allocateNewRegs - :: Reg -> (MRegsState, Int, [(Reg, Reg)]) -> (MRegsState, Int, [(Reg, Reg)]) + allocateNewRegs :: Reg + -> (MRegsState, Int, [(Reg, Reg)]) + -> (MRegsState, Int, [(Reg, Reg)]) allocateNewRegs d@(UnmappedReg _ pk) (fs, mem, lst) = (fs', mem', (d, f) : lst) - where (fs', f, mem') = case acceptable fs of - [] -> (fs, MemoryReg mem pk, mem + 1) - (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem) - - acceptable regs = filter no_conflict (possibleMRegs pk regs) - no_conflict reg = case lookupFM conflicts reg of - Nothing -> True - Just conflicts -> not (d `elementOfRegSet` conflicts) + where + (fs', f, mem') = + case acceptable fs of + [] -> (fs, MemoryReg mem pk, mem + 1) + (IBOX(x2):_) -> (fs `useMReg` x2, MappedReg x2, mem) + + acceptable regs = filter no_conflict (possibleMRegs pk regs) + + no_conflict reg = + case lookupFM conflicts reg of + Nothing -> True + Just conflicts -> not (d `elementOfRegSet` conflicts) \end{code} We keep a local copy of the Prelude function \tr{notElem}, diff --git a/ghc/compiler/nativeGen/MachCode.lhs b/ghc/compiler/nativeGen/MachCode.lhs index 48412e9454..b9f66e88b6 100644 --- a/ghc/compiler/nativeGen/MachCode.lhs +++ b/ghc/compiler/nativeGen/MachCode.lhs @@ -1083,6 +1083,7 @@ getRegister (StPrim primop [x, y]) -- dyadic PrimOps FloatPowerOp -> getRegister (StCall SLIT("pow") DoubleRep [promote x, promote y]) where promote x = StPrim Float2DoubleOp [x] DoublePowerOp -> getRegister (StCall SLIT("pow") DoubleRep [x, y]) +-- _ -> panic "Prim op " ++ (showPrimOp primop) ++ " not handled!" where imul_div fn x y = getRegister (StCall fn IntRep [x, y]) diff --git a/ghc/compiler/nativeGen/StixInteger.lhs b/ghc/compiler/nativeGen/StixInteger.lhs index 37911bc47a..23c6a07f51 100644 --- a/ghc/compiler/nativeGen/StixInteger.lhs +++ b/ghc/compiler/nativeGen/StixInteger.lhs @@ -389,6 +389,7 @@ mpData_mantissa = mpData mantissa Support for the Gnu GMP multi-precision package. \begin{code} +-- size (in words) of __MP_INT mpIntSize = 3 :: Int mpAlloc, mpSize, mpData :: StixTree -> StixTree @@ -406,6 +407,7 @@ mpSpace gmp res sizes = foldr sum (StPrim IntAddOp [fixed, hdrs]) sizes where sum x y = StPrim IntAddOp [StPrim IntAbsOp [x], y] + -- what's the magical 17 for? fixed = StInt (toInteger (17 * res + gmp * mpIntSize)) hdrs = StPrim IntMulOp [dataHS, StInt (toInteger res)] \end{code} diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index 0df070d4e0..6b992e3fe7 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -7,6 +7,7 @@ module StixPrim ( primCode, amodeToStix, amodeToStix' ) where #include "HsVersions.h" +import Char ( ord ) import MachMisc import MachRegs @@ -28,9 +29,6 @@ import StixInteger {- everything -} import UniqSupply ( returnUs, thenUs, UniqSM ) import Outputable -#ifdef REALLY_HASKELL_1_3 -ord = fromEnum :: Char -> Int -#endif \end{code} The main honcho here is primCode, which handles the guts of COpStmts. @@ -407,6 +405,22 @@ primCode [lhs] MakeStablePtrOp args \begin{code} primCode res Word2IntegerOp args = panic "primCode:Word2IntegerOp" +primCode [lhs] SeqOp [a] + = let + {- + The evaluation of seq#'s argument is done by `seqseqseq', + here we just set up the call to it (identical to how + DerefStablePtr does things.) + -} + lhs' = amodeToStix lhs + a' = amodeToStix a + pk = getAmodeRep lhs -- an IntRep + call = StCall SLIT("SeqZhCode") pk [a'] + assign = StAssign pk lhs' call + in +-- trace "SeqOp" $ + returnUs (\xs -> assign : xs) + primCode lhs (CCallOp fn is_asm may_gc arg_tys result_ty) rhs | is_asm = error "ERROR: Native code generator can't handle casm" | otherwise diff --git a/ghc/compiler/parser/hsparser.y b/ghc/compiler/parser/hsparser.y index 780b9e16a6..d3025889de 100644 --- a/ghc/compiler/parser/hsparser.y +++ b/ghc/compiler/parser/hsparser.y @@ -964,6 +964,10 @@ dexp : MINUS kexp { $$ = mknegate($2); } | kexp ; +/* + We need to factor out a leading let expression so we can set + inpat=TRUE when parsing (non let) expressions inside stmts and quals +*/ expLno : oexpLno DCOLON ctype { $$ = mkrestr($1,$3); } | oexpLno ; @@ -1172,7 +1176,7 @@ alts : alt { $$ = $1; } | alts SEMI alt { $$ = lconc($1,$3); } ; -alt : pat { PREVPATT = $1; } altrest { $$ = lsing($3); PREVPATT = NULL; } +alt : pat { PREVPATT = $1; } altrest { expORpat(LEGIT_PATT,$1); $$ = lsing($3); PREVPATT = NULL; } | /* empty */ { $$ = Lnil; } ; @@ -1578,6 +1582,16 @@ vccurly1: * * **********************************************************************/ + +/* +void +checkinpat() +{ + if(!inpat) + hsperror("pattern syntax used in expression"); +} +*/ + /* The parser calls "hsperror" when it sees a `report this and die' error. It sets the stage and calls "yyerror". diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index 3e948ee3ef..692e675321 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -21,7 +21,7 @@ module PrelInfo ( ltH_Float_RDR, eqH_Double_RDR, ltH_Double_RDR, eqH_Int_RDR, ltH_Int_RDR, geH_RDR, leH_RDR, minusH_RDR, false_RDR, true_RDR, and_RDR, not_RDR, append_RDR, map_RDR, compose_RDR, mkInt_RDR, - error_RDR, assert_RDR, + error_RDR, assertErr_RDR, showString_RDR, showParen_RDR, readParen_RDR, lex_RDR, showSpace_RDR, showList___RDR, readList___RDR, negate_RDR, @@ -302,6 +302,7 @@ knownKeyNames -- Others , (otherwiseId_RDR, otherwiseIdKey) + , (assert_RDR, assertIdKey) ] \end{code} @@ -421,7 +422,8 @@ times_RDR = varQual (pREL_BASE, SLIT("*")) mkInt_RDR = varQual (pREL_BASE, SLIT("I#")) error_RDR = varQual (pREL_ERR, SLIT("error")) -assert_RDR = varQual (pREL_ERR, SLIT("assert__")) +assert_RDR = varQual (pREL_GHC, SLIT("assert")) +assertErr_RDR = varQual (pREL_ERR, SLIT("assertError")) eqH_Char_RDR = prelude_primop CharEqOp ltH_Char_RDR = prelude_primop CharLtOp diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 68b2609a40..7777049248 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -276,87 +276,37 @@ ifaceFlavour name = case getNameProvenance name of Looking up a name in the RnEnv. \begin{code} -lookupRn :: RdrName - -> Maybe Name -- Result of environment lookup - -> RnMS s Name -lookupRn rdr_name (Just name) - = -- Found the name in the envt - returnRn name -- In interface mode the only things in - -- the environment are things in local (nested) scopes -lookupRn rdr_name nm@Nothing - = tryLookupRn rdr_name nm `thenRn` \ name_or_error -> - case name_or_error of - Left (nm,err) -> failWithRn nm err - Right nm -> returnRn nm - -tryLookupRn :: RdrName - -> Maybe Name -- Result of environment lookup - -> RnMS s (Either (Name, ErrMsg) Name) -tryLookupRn rdr_name (Just name) - = -- Found the name in the envt - returnRn (Right name) -- In interface mode the only things in - -- the environment are things in local (nested) scopes - --- lookup in environment, but don't flag an error if --- name is not found. -tryLookupRn rdr_name Nothing - = -- We didn't find the name in the environment - getModeRn `thenRn` \ mode -> - case mode of { - SourceMode -> returnRn (Left ( mkUnboundName rdr_name - , unknownNameErr rdr_name)); - -- Source mode; lookup failure is an error - - InterfaceMode _ _ -> - - - ---------------------------------------------------- - -- OK, so we're in interface mode - -- An Unqual is allowed; interface files contain - -- unqualified names for locally-defined things, such as - -- constructors of a data type. - -- So, qualify the unqualified name with the - -- module of the interface file, and try again - case rdr_name of - Unqual occ -> - getModuleRn `thenRn` \ mod -> - newImportedGlobalName mod occ HiFile `thenRn` \ nm -> - returnRn (Right nm) - Qual mod occ hif -> - newImportedGlobalName mod occ hif `thenRn` \ nm -> - returnRn (Right nm) - - } +lookupRn :: NameEnv -> RdrName -> RnMS s Name +lookupRn name_env rdr_name + = case lookupFM name_env rdr_name of + + -- Found it! + Just name -> returnRn name + + -- Not found + Nothing -> getModeRn `thenRn` \ mode -> + case mode of + -- Not found when processing source code; so fail + SourceMode -> failWithRn (mkUnboundName rdr_name) + (unknownNameErr rdr_name) + + -- Not found when processing an imported declaration, + -- so we create a new name for the purpose + InterfaceMode _ -> + case rdr_name of + + Qual mod_name occ hif -> newGlobalName mod_name occ hif + + -- An Unqual is allowed; interface files contain + -- unqualified names for locally-defined things, such as + -- constructors of a data type. + Unqual occ -> getModuleRn `thenRn ` \ mod_name -> + newGlobalName mod_name occ HiFile + lookupBndrRn rdr_name - = lookupNameRn rdr_name `thenRn` \ maybe_name -> - lookupRn rdr_name maybe_name `thenRn` \ name -> - - if isLocalName name then - returnRn name - else - - ---------------------------------------------------- - -- OK, so we're at the binding site of a top-level defn - -- Check to see whether its an imported decl - getModeRn `thenRn` \ mode -> - case mode of { - SourceMode -> returnRn name ; - - InterfaceMode _ print_unqual_fn -> - - ---------------------------------------------------- - -- OK, the binding site of an *imported* defn - -- so we can make the provenance more informative - getSrcLocRn `thenRn` \ src_loc -> - let - name' = case getNameProvenance name of - NonLocalDef _ hif _ -> setNameProvenance name - (NonLocalDef src_loc hif (print_unqual_fn name')) - other -> name - in - returnRn name' - } + = getNameEnv `thenRn` \ name_env -> + lookupRn name_env rdr_name -- Just like lookupRn except that we record the occurrence too -- Perhaps surprisingly, even wired-in names are recorded. @@ -364,39 +314,18 @@ lookupBndrRn rdr_name -- deciding which instance declarations to import. lookupOccRn :: RdrName -> RnMS s Name lookupOccRn rdr_name - = tryLookupOccRn rdr_name `thenRn` \ name_or_error -> - case name_or_error of - Left (nm, err) -> failWithRn nm err - Right nm -> returnRn nm - --- tryLookupOccRn is the fail-safe version of lookupOccRn, returning --- back the error rather than immediately flagging it. It is only --- directly used by RnExpr.rnExpr to catch and rewrite unbound --- uses of `assert'. -tryLookupOccRn :: RdrName -> RnMS s (Either (Name,ErrMsg) Name) -tryLookupOccRn rdr_name - = lookupNameRn rdr_name `thenRn` \ maybe_name -> - tryLookupRn rdr_name maybe_name `thenRn` \ name_or_error -> - case name_or_error of - Left _ -> returnRn name_or_error - Right name -> - let - name' = mungePrintUnqual rdr_name name - in - addOccurrenceName name' `thenRn_` - returnRn name_or_error - + = getNameEnv `thenRn` \ name_env -> + lookupRn name_env rdr_name `thenRn` \ name -> + addOccurrenceName name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global --- environment only. It's used for record field names only. +-- environment. It's used for record field names only. lookupGlobalOccRn :: RdrName -> RnMS s Name lookupGlobalOccRn rdr_name - = lookupGlobalNameRn rdr_name `thenRn` \ maybe_name -> - lookupRn rdr_name maybe_name `thenRn` \ name -> - let - name' = mungePrintUnqual rdr_name name - in - addOccurrenceName name' + = getGlobalNameEnv `thenRn` \ name_env -> + lookupRn name_env rdr_name `thenRn` \ name -> + addOccurrenceName name + -- mungePrintUnqual is used to make *imported* *occurrences* print unqualified -- if they were mentioned unqualified in the source code. @@ -619,7 +548,10 @@ filterAvail :: RdrNameIE -- Wanted filterAvail ie@(IEThingWith want wants) avail@(AvailTC n ns) | sub_names_ok = AvailTC n (filter is_wanted ns) - | otherwise = pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $ + | otherwise = +#ifdef DEBUG + pprTrace "filterAvail" (hsep [ppr ie, pprAvail avail]) $ +#endif NotAvailable where is_wanted name = nameOccName name `elem` wanted_occs diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 5d9092b330..f0ef83e872 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -30,7 +30,7 @@ import BasicTypes ( Fixity(..), FixityDirection(..), IfaceFlavour(..) ) import PrelInfo ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, ccallableClass_RDR, creturnableClass_RDR, monadZeroClass_RDR, enumClass_RDR, ordClass_RDR, - ratioDataCon_RDR, negate_RDR, assert_RDR, + ratioDataCon_RDR, negate_RDR, assertErr_RDR, ioDataCon_RDR, ioOkDataCon_RDR ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, @@ -248,7 +248,7 @@ free-var set iff if it's a LocallyDefined Name. rnExpr :: RdrNameHsExpr -> RnMS s (RenamedHsExpr, FreeVars) rnExpr (HsVar v) - = tryLookupOccRn v `thenRn` \ res -> + = lookupOccRn v `thenRn` \ name -> case res of Left (nm,err) | opt_GlasgowExts && v == assertRdrName -> @@ -744,11 +744,8 @@ mkAssertExpr = returnRn (expr, name) where - mod = rdrNameModule assert_RDR - occ = rdrNameOcc assert_RDR - -assertRdrName :: RdrName -assertRdrName = Unqual (VarOcc SLIT("assert")) + mod = rdrNameModule assertErr_RDR + occ = rdrNameOcc assertErr_RDR \end{code} %************************************************************************ diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs index 0e80f1ea1b..99e34ab634 100644 --- a/ghc/compiler/simplCore/SimplCase.lhs +++ b/ghc/compiler/simplCore/SimplCase.lhs @@ -1,4 +1,4 @@ -`% +% % (c) The AQUA Project, Glasgow University, 1994-1996 % \section[SimplCase]{Simplification of `case' expression} @@ -37,6 +37,7 @@ import TyCon ( isDataTyCon ) import TysPrim ( voidTy ) import Util ( Eager, runEager, appEager, isIn, isSingleton, zipEqual, panic, assertPanic ) +import Outputable \end{code} Float let out of case. @@ -685,7 +686,7 @@ completeAlgCaseWithKnownCon -> (SimplEnv -> InExpr -> SmplM OutExpr) -- Rhs handler -> SmplM OutExpr -completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c +completeAlgCaseWithKnownCon env con con_args a@(AlgAlts alts deflt) rhs_c = ASSERT(isDataCon con) search_alts alts where @@ -709,7 +710,8 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c = -- No matching alternative case deflt of NoDefault -> -- Blargh! - panic "completeAlgCaseWithKnownCon: No matching alternative and no default" + pprPanic "completeAlgCaseWithKnownCon: No matching alternative and no default" + (ppr con <+> ppr con_args $$ ppr a) BindDefault binder@(_,occ_info) rhs -> -- OK, there's a default case -- let-bind the binder to the constructor diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 7bb409edff..f2d9c9396d 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -284,7 +284,6 @@ tcBindWithSigs top_lvl binder_names mbind tc_ty_sigs is_rec prag_info_fn -- -- Also NB that tcSimplify takes zonked tyvars as its arg, hence we pass -- real_tyvars_to_gen - -- in -- SIMPLIFY THE LIE diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 675a7924da..4f0d6eee79 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -265,27 +265,6 @@ tcCoreExpr (UfNote note expr) tcCoreNote (UfSCC cc) = returnTc (SCC cc) tcCoreNote UfInlineCall = returnTc InlineCall \end{code} - returnTc (Note note' expr') - -tcCoreExpr (UfLam bndr body) - = tcCoreLamBndr bndr $ \ bndr' -> - tcCoreExpr body `thenTc` \ body' -> - returnTc (Lam bndr' body') - -tcCoreExpr (UfLet (UfNonRec bndr rhs) body) - = tcCoreExpr rhs `thenTc` \ rhs' -> - tcCoreValBndr bndr $ \ bndr' -> - tcCoreExpr body `thenTc` \ body' -> - returnTc (Let (NonRec bndr' rhs') body') - -tcCoreExpr (UfLet (UfRec pairs) body) - = tcCoreValBndrs bndrs $ \ bndrs' -> - mapTc tcCoreExpr rhss `thenTc` \ rhss' -> - tcCoreExpr body `thenTc` \ body' -> - returnTc (Let (Rec (bndrs' `zip` rhss')) body') - where - (bndrs, rhss) = unzip pairs -\end{code} \begin{code} tcCoreLamBndr (UfValBinder name ty) thing_inside diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 1c1b1f00ff..d59e0d5ba3 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -431,13 +431,15 @@ tcInstDecl2 (InstInfo clas inst_tyvars inst_tys -- mention the constructor, which doesn't exist for CCallable, CReturnable -- Hardly beautiful, but only three extra lines. HsApp (TyApp (HsVar (RealId eRROR_ID)) [tcIdType this_dict_id]) - (HsLit (HsString (_PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas))))) + (HsLitOut (HsString msg) stringTy) | otherwise -- The common case = foldl HsApp (TyApp (HsVar (RealId dict_constr)) inst_tys') (map HsVar (sc_dict_ids ++ meth_ids)) -- We don't produce a binding for the dict_constr; instead we -- rely on the simplifier to unfold this saturated application + where + msg = _PK_ ("Compiler error: bad dictionary " ++ showSDoc (ppr clas)) dict_bind = VarMonoBind this_dict_id dict_rhs method_binds = andMonoBinds method_binds_s @@ -491,7 +493,7 @@ tcInstMethodBind clas inst_tys inst_tyvars meth_binds prags (sel_id, maybe_dm_id -- Warn if no method binding, only if -fwarn-missing-methods - warnTc (opt_WarnMissingMethods && + warnTc (opt_WarnMissingMethods && not (maybeToBool maybe_meth_bind) && not (maybeToBool maybe_dm_id)) (omittedMethodWarn sel_id clas) `thenNF_Tc_` @@ -532,143 +534,10 @@ tcInstMethodBind clas inst_tys inst_tyvars meth_binds prags (sel_id, maybe_dm_id %************************************************************************ %* * -\subsection{Type-checking specialise instance pragmas} +\subsection{Checking for a decent instance type} %* * %************************************************************************ -\begin{code} -{- LATER -tcSpecInstSigs :: E -> CE -> TCE - -> Bag InstInfo -- inst decls seen (declared and derived) - -> [RenamedSpecInstSig] -- specialise instance upragmas - -> TcM (Bag InstInfo) -- new, overlapped, inst decls - -tcSpecInstSigs e ce tce inst_infos [] - = returnTc emptyBag - -tcSpecInstSigs e ce tce inst_infos sigs - = buildInstanceEnvs inst_infos `thenTc` \ inst_mapper -> - tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ spec_inst_infos -> - returnTc spec_inst_infos - where - tc_inst_spec_sigs inst_mapper [] - = returnNF_Tc emptyBag - tc_inst_spec_sigs inst_mapper (sig:sigs) - = tcSpecInstSig e ce tce inst_infos inst_mapper sig `thenNF_Tc` \ info_sig -> - tc_inst_spec_sigs inst_mapper sigs `thenNF_Tc` \ info_sigs -> - returnNF_Tc (info_sig `unionBags` info_sigs) - -tcSpecInstSig :: E -> CE -> TCE - -> Bag InstInfo - -> InstanceMapper - -> RenamedSpecInstSig - -> NF_TcM (Bag InstInfo) - -tcSpecInstSig e ce tce inst_infos inst_mapper (SpecInstSig class_name ty src_loc) - = recoverTc emptyBag ( - tcAddSrcLoc src_loc ( - let - clas = lookupCE ce class_name -- Renamer ensures this can't fail - - -- Make some new type variables, named as in the specialised instance type - ty_names = extractHsTyNames ???is_tyvarish_name??? ty - (tmpl_e,inst_tmpls,inst_tmpl_tys) = mkTVE ty_names - in - babyTcMtoTcM (tcInstanceType ce tce tmpl_e True src_loc ty) - `thenTc` \ inst_ty -> - let - maybe_tycon = case splitAlgTyConApp_maybe inst_ty of - Just (tc,_,_) -> Just tc - Nothing -> Nothing - - maybe_unspec_inst = lookup_unspec_inst clas maybe_tycon inst_infos - in - -- Check that we have a local instance declaration to specialise - checkMaybeTc maybe_unspec_inst - (specInstUnspecInstNotFoundErr clas inst_ty src_loc) `thenTc_` - - -- Create tvs to substitute for tmpls while simplifying the context - copyTyVars inst_tmpls `thenNF_Tc` \ (tv_e, inst_tvs, inst_tv_tys) -> - let - Just (InstInfo _ unspec_tyvars unspec_inst_ty unspec_theta - _ _ binds _ uprag) = maybe_unspec_inst - - subst = case matchTy unspec_inst_ty inst_ty of - Just subst -> subst - Nothing -> panic "tcSpecInstSig:matchTy" - - subst_theta = instantiateThetaTy subst unspec_theta - subst_tv_theta = instantiateThetaTy tv_e subst_theta - - mk_spec_origin clas ty - = InstanceSpecOrigin inst_mapper clas ty src_loc - -- I'm VERY SUSPICIOUS ABOUT THIS - -- the inst-mapper is in a knot at this point so it's no good - -- looking at it in tcSimplify... - in - tcSimplifyThetas mk_spec_origin subst_tv_theta - `thenTc` \ simpl_tv_theta -> - let - simpl_theta = [ (clas, tv_to_tmpl tv) | (clas, tv) <- simpl_tv_theta ] - - tv_tmpl_map = zipEqual "tcSpecInstSig" inst_tv_tys inst_tmpl_tys - tv_to_tmpl tv = assoc "tcSpecInstSig" tv_tmpl_map tv - in - mkInstanceRelatedIds clas inst_tmpls inst_ty simpl_theta uprag - `thenNF_Tc` \ (dfun_id, dfun_theta, const_meth_ids) -> - - getSwitchCheckerTc `thenNF_Tc` \ sw_chkr -> - (if sw_chkr SpecialiseTrace then - pprTrace "Specialised Instance: " - (vcat [hsep [if null simpl_theta then empty else ppr simpl_theta, - if null simpl_theta then empty else ptext SLIT("=>"), - ppr clas, - pprParendType inst_ty], - hsep [ptext SLIT(" derived from:"), - if null unspec_theta then empty else ppr unspec_theta, - if null unspec_theta then empty else ptext SLIT("=>"), - ppr clas, - pprParendType unspec_inst_ty]]) - else id) ( - - returnTc (unitBag (InstInfo clas inst_tmpls inst_ty simpl_theta - dfun_theta dfun_id - binds src_loc uprag)) - ))) - - -lookup_unspec_inst clas maybe_tycon inst_infos - = case filter (match_info match_inst_ty) (bagToList inst_infos) of - [] -> Nothing - (info:_) -> Just info - where - match_info match_ty (InstInfo inst_clas _ inst_ty _ _ _ _ _ from_here _ _ _) - = from_here && clas == inst_clas && - match_ty inst_ty && is_plain_instance inst_ty - - match_inst_ty = case maybe_tycon of - Just tycon -> match_tycon tycon - Nothing -> match_fun - - match_tycon tycon inst_ty = case (splitAlgTyConApp_maybe inst_ty) of - Just (inst_tc,_,_) -> tycon == inst_tc - Nothing -> False - - match_fun inst_ty = isFunType inst_ty - - -is_plain_instance inst_ty - = case (splitAlgTyConApp_maybe inst_ty) of - Just (_,tys,_) -> all isTyVarTemplateTy tys - Nothing -> case maybeUnpackFunTy inst_ty of - Just (arg, res) -> isTyVarTemplateTy arg && isTyVarTemplateTy res - Nothing -> error "TcInstDecls:is_plain_instance" --} -\end{code} - - -Checking for a decent instance type -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @scrutiniseInstanceType@ checks the type {\em and} its syntactic constraints: it must normally look like: @instance Foo (Tycon a b c ...) ...@ diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index e1155b0b2a..6195aea52e 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -36,7 +36,7 @@ import Type ( splitFunTys, splitRhoTy, import TysPrim ( charPrimTy, intPrimTy, floatPrimTy, doublePrimTy, addrPrimTy ) -import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy ) +import TysWiredIn ( charTy, stringTy, mkListTy, mkTupleTy, intTy ) import Unique ( Unique, eqClassOpKey, geClassOpKey, minusClassOpKey ) import Util ( assertPanic, panic ) import Outputable @@ -295,7 +295,8 @@ tcPat (LitPatIn lit@(HsFrac f)) origin = LiteralOrigin lit tcPat (LitPatIn lit@(HsLitLit s)) - = error "tcPat: can't handle ``literal-literal'' patterns" +-- = error "tcPat: can't handle ``literal-literal'' patterns" + = returnTc (LitPat lit intTy, emptyLIE, intTy) tcPat (NPlusKPatIn name lit@(HsInt i)) = tcLookupLocalValueOK "tcPat1:n+k" name `thenNF_Tc` \ local -> diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index c34404b2f8..fb73907943 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -280,10 +280,32 @@ pprCols = (100 :: Int) -- could make configurable printDoc :: Mode -> Handle -> Doc -> IO () printDoc mode hdl doc = fullRender mode pprCols 1.5 put done doc +{- + = _readHandle hdl >>= \ htype -> + let fp = _filePtr htype in + fullRender mode pprCols 1.5 (put (fp::_Addr)) (done fp) doc +-} where - put (Chr c) next = hPutChar hdl c >> next - put (Str s) next = hPutStr hdl s >> next - put (PStr s) next = hPutFS hdl s >> next +{- + put fp (Chr c) next = _scc_ "hPutChar" ((_ccall_ stg_putc c (fp::_Addr))::PrimIO ()) `seqPrimIO` next + put fp (Str s) next = _scc_ "hPutStr" (put_str fp s) >> next + put fp (PStr s) next = _scc_ "hPutFS" (put_str fp (_UNPK_ s)) >> next + + put_str fp (c1@(C# _) : cs) + = _ccall_ stg_putc c1 (fp::_Addr) `seqPrimIO` + put_str fp cs + put_str fp [] = return () +-} + put (Chr c) next = _scc_ "hPutChar" (hPutChar hdl c) >> next + put (Str s) next = _scc_ "hPutStr" (hPutStr hdl s) >> next + put (PStr s) next = _scc_ "hPutFS" (hPutFS hdl s) >> next + +{- + string_txt (Chr c) s2 = c : s2 + string_txt (Str s1) s2 = s1 ++ s2 + string_txt (PStr s1) s2 = _UNPK_ s1 ++ s2 + done fp = ((_ccall_ stg_putc '\n' (fp::_Addr))::PrimIO ()) `seqPrimIO` return () --hPutChar hdl '\n' +-} done = hPutChar hdl '\n' \end{code} diff --git a/ghc/lib/exts/IOExts.lhs b/ghc/lib/exts/IOExts.lhs index 52ecb16cdd..4489ba6a99 100644 --- a/ghc/lib/exts/IOExts.lhs +++ b/ghc/lib/exts/IOExts.lhs @@ -29,6 +29,9 @@ module IOExts , openFileEx , IOModeEx(..) +-- , setEcho +-- , getEcho + , trace , performGC @@ -89,3 +92,9 @@ writeIOArray (IOArray arr) ix elt = stToIO (writeArray arr ix elt) freezeIOArray (IOArray arr) = stToIO (freezeArray arr) \end{code} +begin{code} +setEcho :: Handle -> Bool -> IO () +setEcho + +getEcho :: Handle -> IO Bool +end{code} diff --git a/ghc/lib/misc/Pretty.lhs b/ghc/lib/misc/Pretty.lhs index 4e19f36b8c..c15b1b9502 100644 --- a/ghc/lib/misc/Pretty.lhs +++ b/ghc/lib/misc/Pretty.lhs @@ -1,421 +1,908 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 -% -\section[Pretty]{Pretty-printing data type} +********************************************************************************* +* * +* John Hughes's and Simon Peyton Jones's Pretty Printer Combinators * +* * +* based on "The Design of a Pretty-printing Library" * +* in Advanced Functional Programming, * +* Johan Jeuring and Erik Meijer (eds), LNCS 925 * +* http://www.cs.chalmers.se/~rjmh/Papers/pretty.ps * +* * +* Heavily modified by Simon Peyton Jones, Dec 96 * +* * +********************************************************************************* + +Version 3.0 28 May 1997 + * Cured massive performance bug. If you write + + foldl <> empty (map (text.show) [1..10000]) + + you get quadratic behaviour with V2.0. Why? For just the same reason as you get + quadratic behaviour with left-associated (++) chains. + + This is really bad news. One thing a pretty-printer abstraction should + certainly guarantee is insensivity to associativity. It matters: suddenly + GHC's compilation times went up by a factor of 100 when I switched to the + new pretty printer. + + I fixed it with a bit of a hack (because I wanted to get GHC back on the + road). I added two new constructors to the Doc type, Above and Beside: + + <> = Beside + $$ = Above + + Then, where I need to get to a "TextBeside" or "NilAbove" form I "force" + the Doc to squeeze out these suspended calls to Beside and Above; but in so + doing I re-associate. It's quite simple, but I'm not satisfied that I've done + the best possible job. I'll send you the code if you are interested. + + * Added new exports: + punctuate, hang + int, integer, float, double, rational, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + + * fullRender's type signature has changed. Rather than producing a string it + now takes an extra couple of arguments that tells it how to glue fragments + of output together: + + fullRender :: Mode + -> Int -- Line length + -> Float -- Ribbons per line + -> (TextDetails -> a -> a) -- What to do with text + -> a -- What to do at the end + -> Doc + -> a -- Result + + The "fragments" are encapsulated in the TextDetails data type: + data TextDetails = Chr Char + | Str String + | PStr FAST_STRING + + The Chr and Str constructors are obvious enough. The PStr constructor has a packed + string (FAST_STRING) inside it. It's generated by using the new "ptext" export. + + An advantage of this new setup is that you can get the renderer to do output + directly (by passing in a function of type (TextDetails -> IO () -> IO ()), + rather than producing a string that you then print. + + +Version 2.0 24 April 1997 + * Made empty into a left unit for <> as well as a right unit; + it is also now true that + nest k empty = empty + which wasn't true before. + + * Fixed an obscure bug in sep that occassionally gave very wierd behaviour + + * Added $+$ + + * Corrected and tidied up the laws and invariants + +====================================================================== +Relative to John's original paper, there are the following new features: + +1. There's an empty document, "empty". It's a left and right unit for + both <> and $$, and anywhere in the argument list for + sep, hcat, hsep, vcat, fcat etc. + + It is Really Useful in practice. + +2. There is a paragraph-fill combinator, fsep, that's much like sep, + only it keeps fitting things on one line until itc can't fit any more. + +3. Some random useful extra combinators are provided. + <+> puts its arguments beside each other with a space between them, + unless either argument is empty in which case it returns the other + + + hcat is a list version of <> + hsep is a list version of <+> + vcat is a list version of $$ + + sep (separate) is either like hsep or like vcat, depending on what fits + + cat is behaves like sep, but it uses <> for horizontal conposition + fcat is behaves like fsep, but it uses <> for horizontal conposition + + These new ones do the obvious things: + char, semi, comma, colon, space, + parens, brackets, braces, + quotes, doubleQuotes + +4. The "above" combinator, $$, now overlaps its two arguments if the + last line of the top argument stops before the first line of the second begins. + For example: text "hi" $$ nest 5 "there" + lays out as + hi there + rather than + hi + there + + There are two places this is really useful + + a) When making labelled blocks, like this: + Left -> code for left + Right -> code for right + LongLongLongLabel -> + code for longlonglonglabel + The block is on the same line as the label if the label is + short, but on the next line otherwise. + + b) When laying out lists like this: + [ first + , second + , third + ] + which some people like. But if the list fits on one line + you want [first, second, third]. You can't do this with + John's original combinators, but it's quite easy with the + new $$. + + The combinator $+$ gives the original "never-overlap" behaviour. + +5. Several different renderers are provided: + * a standard one + * one that uses cut-marks to avoid deeply-nested documents + simply piling up in the right-hand margin + * one that ignores indentation (fewer chars output; good for machines) + * one that ignores indentation and newlines (ditto, only more so) + +6. Numerous implementation tidy-ups + Use of unboxed data types to speed up the implementation -\begin{code} -#if defined(COMPILING_GHC) -# include "HsVersions.h" -#else -# define FAST_STRING String -# define _LENGTH_ length -#endif + +\begin{code} module Pretty ( + Doc, -- Abstract + Mode(..), TextDetails(..), + + empty, isEmpty, nest, -#if defined(COMPILING_GHC) - SYN_IE(Pretty), - prettyToUn, -#else - Pretty, -#endif - ppNil, ppStr, ppPStr, ppChar, ppInt, ppInteger, - ppFloat, ppDouble, -#if __GLASGOW_HASKELL__ - -- may be able to *replace* ppDouble - ppRational, -#endif - ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, - ppSemi, ppComma, ppEquals, - ppBracket, ppParens, ppQuote, - - ppCat, ppBeside, ppBesides, ppAbove, ppAboves, - ppNest, ppSep, ppHang, ppInterleave, ppIntersperse, - ppShow, speakNth, - -#if defined(COMPILING_GHC) - ppPutStr, -#endif - - -- abstract type, to complete the interface... - --PrettyRep(..), Delay - ) where - -#if defined(COMPILING_GHC) - -CHK_Ubiq() -- debugging consistency check -IMPORT_1_3(Ratio) -IMPORT_1_3(IO) - -import Unpretty ( SYN_IE(Unpretty) ) -#else -import Ratio -#endif - -import CharSeq + text, char, ptext, + int, integer, float, double, rational, + parens, brackets, braces, quotes, doubleQuotes, + semi, comma, colon, space, equals, + lparen, rparen, lbrack, rbrack, lbrace, rbrace, + + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + + hang, punctuate, + +-- renderStyle, -- Haskell 1.3 only + render, fullRender + ) where + +-- Don't import Util( assertPanic ) because it makes a loop in the module structure + +infixl 6 <> +infixl 6 <+> +infixl 5 $$, $+$ \end{code} -Based on John Hughes's pretty-printing library. Loosely. Very -loosely. -%************************************************ -%* * - \subsection{The interface} -%* * -%************************************************ + +********************************************************* +* * +\subsection{CPP magic so that we can compile with both GHC and Hugs} +* * +********************************************************* + +The library uses unboxed types to get a bit more speed, but these CPP macros +allow you to use either GHC or Hugs. To get GHC, just set the CPP variable + __GLASGOW_HASKELL__ + + +********************************************************* +* * +\subsection{The interface} +* * +********************************************************* + +The primitive @Doc@ values \begin{code} -ppNil :: Pretty -ppSP, pp'SP, ppLbrack, ppRbrack, ppLparen, ppRparen, ppSemi, ppComma, ppEquals :: Pretty - -ppStr :: [Char] -> Pretty -ppPStr :: FAST_STRING -> Pretty -ppChar :: Char -> Pretty -ppInt :: Int -> Pretty -ppInteger :: Integer -> Pretty -ppDouble :: Double -> Pretty -ppFloat :: Float -> Pretty -ppRational :: Rational -> Pretty - -ppBracket :: Pretty -> Pretty -- put brackets around it -ppParens :: Pretty -> Pretty -- put parens around it - -ppBeside :: Pretty -> Pretty -> Pretty -ppBesides :: [Pretty] -> Pretty -ppBesideSP :: Pretty -> Pretty -> Pretty -ppCat :: [Pretty] -> Pretty -- i.e., ppBesidesSP - -ppAbove :: Pretty -> Pretty -> Pretty -ppAboves :: [Pretty] -> Pretty - -ppInterleave :: Pretty -> [Pretty] -> Pretty -ppIntersperse :: Pretty -> [Pretty] -> Pretty -- no spaces between, no ppSep -ppSep :: [Pretty] -> Pretty -ppHang :: Pretty -> Int -> Pretty -> Pretty -ppNest :: Int -> Pretty -> Pretty - -ppShow :: Int -> Pretty -> [Char] - -#if defined(COMPILING_GHC) -ppPutStr :: Handle -> Int -> Pretty -> IO () -#endif +empty :: Doc +isEmpty :: Doc -> Bool +text :: String -> Doc +char :: Char -> Doc + +semi, comma, colon, space, equals :: Doc +lparen, rparen, lbrack, rbrack, lbrace, rbrace :: Doc + +parens, brackets, braces :: Doc -> Doc +quotes, doubleQuotes :: Doc -> Doc + +int :: Int -> Doc +integer :: Integer -> Doc +float :: Float -> Doc +double :: Double -> Doc +rational :: Rational -> Doc \end{code} -%************************************************ -%* * - \subsection{The representation} -%* * -%************************************************ +Combining @Doc@ values \begin{code} -type Pretty = Int -- The width to print in - -> Bool -- True => vertical context - -> PrettyRep +(<>) :: Doc -> Doc -> Doc -- Beside +hcat :: [Doc] -> Doc -- List version of <> +(<+>) :: Doc -> Doc -> Doc -- Beside, separated by space +hsep :: [Doc] -> Doc -- List version of <+> -data PrettyRep - = MkPrettyRep CSeq -- The text - (Delay Int) -- No of chars in last line - Bool -- True if empty object - Bool -- Fits on a single line in specified width +($$) :: Doc -> Doc -> Doc -- Above; if there is no + -- overlap it "dovetails" the two +vcat :: [Doc] -> Doc -- List version of $$ + +cat :: [Doc] -> Doc -- Either hcat or vcat +sep :: [Doc] -> Doc -- Either hsep or vcat +fcat :: [Doc] -> Doc -- ``Paragraph fill'' version of cat +fsep :: [Doc] -> Doc -- ``Paragraph fill'' version of sep + +nest :: Int -> Doc -> Doc -- Nested +\end{code} -data Delay a = MkDelay a +GHC-specific ones. -forceDel (MkDelay _) r = r +\begin{code} +hang :: Doc -> Int -> Doc -> Doc +punctuate :: Doc -> [Doc] -> [Doc] -- punctuate p [d1, ... dn] = [d1 <> p, d2 <> p, ... dn-1 <> p, dn] +\end{code} -forceBool True r = r -forceBool False r = r +Displaying @Doc@ values. -forceInfo ll emp sl r = forceDel ll (forceBool emp (forceBool sl r)) +\begin{code} +instance Show Doc where + showsPrec prec doc cont = showDoc doc cont + +render :: Doc -> String -- Uses default style +fullRender :: Mode + -> Int -- Line length + -> Float -- Ribbons per line + -> (TextDetails -> a -> a) -- What to do with text + -> a -- What to do at the end + -> Doc + -> a -- Result + +{- When we start using 1.3 +renderStyle :: Style -> Doc -> String +data Style = Style { lineLength :: Int, -- In chars + ribbonsPerLine :: Float, -- Ratio of ribbon length to line length + mode :: Mode + } +style :: Style -- The default style +style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode } +-} -ppShow width p - = case (p width False) of - MkPrettyRep seq ll emp sl -> cShow seq +data Mode = PageMode -- Normal + | ZigZagMode -- With zig-zag cuts + | LeftMode -- No indentation, infinitely long lines + | OneLineMode -- All on one line -#if defined(COMPILING_GHC) -ppPutStr f width p - = case (p width False) of - MkPrettyRep seq ll emp sl -> cPutStr f seq -#endif +\end{code} -ppNil width is_vert = MkPrettyRep cNil (MkDelay 0) True (width >= 0) - -- Doesn't fit if width < 0, otherwise, ppNil - -- will make ppBesides always return True. -ppStr s width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls) - where ls = length s -ppPStr s width is_vert = MkPrettyRep (cPStr s) (MkDelay ls) False (width >= ls) - where ls = _LENGTH_ s -ppChar c width is_vert = MkPrettyRep (cCh c) (MkDelay 1) False (width >= 1) +********************************************************* +* * +\subsection{The @Doc@ calculus} +* * +********************************************************* -ppInt n width is_vert = MkPrettyRep (cStr s) (MkDelay ls) False (width >= ls) - where s = show n; ls = length s +The @Doc@ combinators satisfy the following laws: +\begin{verbatim} +Laws for $$ +~~~~~~~~~~~ +<a1> (x $$ y) $$ z = x $$ (y $$ z) +<a2> empty $$ x = x +<a3> x $$ empty = x -ppInteger n = ppStr (show n) -ppDouble n = ppStr (show n) -ppFloat n = ppStr (show n) + ...ditto $+$... -ppRational n = ppStr (show (fromRationalX n)) -- _showRational 30 n) +Laws for <> +~~~~~~~~~~~ +<b1> (x <> y) <> z = x <> (y <> z) +<b2> empty <> x = empty +<b3> x <> empty = x -ppSP = ppChar ' ' -pp'SP = ppStr ", " -ppLbrack = ppChar '[' -ppRbrack = ppChar ']' -ppLparen = ppChar '(' -ppRparen = ppChar ')' -ppSemi = ppChar ';' -ppComma = ppChar ',' -ppEquals = ppChar '=' + ...ditto <+>... -ppBracket p = ppBeside ppLbrack (ppBeside p ppRbrack) -ppParens p = ppBeside ppLparen (ppBeside p ppRparen) -ppQuote p = ppBeside (ppChar '`') (ppBeside p (ppChar '\'')) +Laws for text +~~~~~~~~~~~~~ +<t1> text s <> text t = text (s++t) +<t2> text "" <> x = x, if x non-empty -ppInterleave sep ps = ppSep (pi ps) - where - pi [] = [] - pi [x] = [x] - pi (x:xs) = (ppBeside x sep) : pi xs +Laws for nest +~~~~~~~~~~~~~ +<n1> nest 0 x = x +<n2> nest k (nest k' x) = nest (k+k') x +<n3> nest k (x <> y) = nest k z <> nest k y +<n4> nest k (x $$ y) = nest k x $$ nest k y +<n5> nest k empty = empty +<n6> x <> nest k y = x <> y, if x non-empty + +** Note the side condition on <n6>! It is this that +** makes it OK for empty to be a left unit for <>. + +Miscellaneous +~~~~~~~~~~~~~ +<m1> (text s <> x) $$ y = text s <> ((text "" <> x)) $$ + nest (-length s) y) + +<m2> (x $$ y) <> z = x $$ (y <> z) + if y non-empty + + +Laws for list versions +~~~~~~~~~~~~~~~~~~~~~~ +<l1> sep (ps++[empty]++qs) = sep (ps ++ qs) + ...ditto hsep, hcat, vcat, fill... + +<l2> nest k (sep ps) = sep (map (nest k) ps) + ...ditto hsep, hcat, vcat, fill... + +Laws for oneLiner +~~~~~~~~~~~~~~~~~ +<o1> oneLiner (nest k p) = nest k (oneLiner p) +<o2> oneLiner (x <> y) = oneLiner x <> oneLiner y +\end{verbatim} + + +You might think that the following verion of <m1> would +be neater: +\begin{verbatim} +<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ + nest (-length s) y) +\end{verbatim} +But it doesn't work, for if x=empty, we would have +\begin{verbatim} + text s $$ y = text s <> (empty $$ nest (-length s) y) + = text s <> nest (-length s) y +\end{verbatim} + + + +********************************************************* +* * +\subsection{Simple derived definitions} +* * +********************************************************* + +\begin{code} +semi = char ';' +colon = char ':' +comma = char ',' +space = char ' ' +equals = char '=' +lparen = char '(' +rparen = char ')' +lbrack = char '[' +rbrack = char ']' +lbrace = char '{' +rbrace = char '}' + +int n = text (show n) +integer n = text (show n) +float n = text (show n) +double n = text (show n) +rational n = text (show n) +-- SIGBJORN wrote instead: +-- rational n = text (show (fromRationalX n)) + +quotes p = char '`' <> p <> char '\'' +doubleQuotes p = char '"' <> p <> char '"' +parens p = char '(' <> p <> char ')' +brackets p = char '[' <> p <> char ']' +braces p = char '{' <> p <> char '}' + + +hcat = foldr (<>) empty +hsep = foldr (<+>) empty +vcat = foldr ($$) empty + +hang d1 n d2 = d1 $$ (nest n d2) + +punctuate p [] = [] +punctuate p (d:ds) = go d ds + where + go d [] = [d] + go d (e:es) = (d <> p) : go e es \end{code} -ToDo: this could be better: main pt is: no extra spaces in between. +********************************************************* +* * +\subsection{The @Doc@ data type} +* * +********************************************************* + +A @Doc@ represents a {\em set} of layouts. A @Doc@ with +no occurrences of @Union@ or @NoDoc@ represents just one layout. \begin{code} -ppIntersperse sep ps = ppBesides (pi ps) - where - pi [] = [] - pi [x] = [x] - pi (x:xs) = (ppBeside x sep) : pi xs +data Doc + = Empty -- empty + | NilAbove Doc -- text "" $$ x + | TextBeside TextDetails Int Doc -- text s <> x + | Nest Int Doc -- nest k x + | Union Doc Doc -- ul `union` ur + | NoDoc -- The empty set of documents + | Beside Doc Bool Doc -- True <=> space between + | Above Doc Bool Doc -- True <=> never overlap + +type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside + + +reduceDoc :: Doc -> RDoc +reduceDoc (Beside p g q) = beside p g (reduceDoc q) +reduceDoc (Above p g q) = above p g (reduceDoc q) +reduceDoc p = p + + +data TextDetails = Chr Char + | Str String + | PStr String +space_text = Chr ' ' +nl_text = Chr '\n' \end{code} -Laziness is important in @ppBeside@. If the first thing is not a -single line it will return @False@ for the single-line boolean without -laying out the second. +Here are the invariants: +\begin{itemize} +\item +The argument of @NilAbove@ is never @Empty@. Therefore +a @NilAbove@ occupies at least two lines. + +\item +The arugment of @TextBeside@ is never @Nest@. + +\item +The layouts of the two arguments of @Union@ both flatten to the same string. + +\item +The arguments of @Union@ are either @TextBeside@, or @NilAbove@. + +\item +The right argument of a union cannot be equivalent to the empty set (@NoDoc@). +If the left argument of a union is equivalent to the empty set (@NoDoc@), +then the @NoDoc@ appears in the first line. + +\item +An empty document is always represented by @Empty@. +It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s. + +\item +The first line of every layout in the left argument of @Union@ +is longer than the first line of any layout in the right argument. +(1) ensures that the left argument has a first line. In view of (3), +this invariant means that the right argument must have at least two +lines. +\end{itemize} \begin{code} -ppBeside p1 p2 width is_vert - = case (p1 width False) of - MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> - MkPrettyRep (seq1 `cAppend` (cIndent ll1 seq2)) - (MkDelay (ll1 + ll2)) - (emp1 && emp2) - ((width >= 0) && (sl1 && sl2)) - -- This sequence of (&&)'s ensures that ppBeside - -- returns a False for sl as soon as possible. - where -- NB: for case alt - seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 - MkDelay ll2 = x_ll2 - MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-ll1) False - -- ToDo: if emp{1,2} then we really - -- should be passing on "is_vert" to p{2,1}. - -ppBesides [] = ppNil -ppBesides ps = foldr1 ppBeside ps + -- Arg of a NilAbove is always an RDoc +nilAbove_ p = NilAbove p + + -- Arg of a TextBeside is always an RDoc +textBeside_ s sl p = TextBeside s sl p + + -- Arg of Nest is always an RDoc +nest_ k p = Nest k p + + -- Args of union are always RDocs +union_ p q = Union p q + \end{code} -@ppBesideSP@ puts two things beside each other separated by a space. + +Notice the difference between + * NoDoc (no documents) + * Empty (one empty document; no height and no width) + * text "" (a document containing the empty string; + one line high, but has no width) + + + +********************************************************* +* * +\subsection{@empty@, @text@, @nest@, @union@} +* * +********************************************************* \begin{code} -ppBesideSP p1 p2 width is_vert - = case (p1 width False) of - MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> - MkPrettyRep (seq1 `cAppend` (sp `cAppend` (cIndent li seq2))) - (MkDelay (li + ll2)) - (emp1 && emp2) - ((width >= wi) && (sl1 && sl2)) - where -- NB: for case alt - seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 - MkDelay ll2 = x_ll2 - MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-li) False - li, wi :: Int - li = if emp1 then 0 else ll1+1 - wi = if emp1 then 0 else 1 - sp = if emp1 || emp2 then cNil else (cCh ' ') +empty = Empty + +isEmpty Empty = True +isEmpty _ = False + +char c = textBeside_ (Chr c) 1 Empty +text s = case length s of {sl -> textBeside_ (Str s) sl Empty} +ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty} + +nest k p = mkNest k (reduceDoc p) -- Externally callable version + +-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it +mkNest k (Nest k1 p) = mkNest (k + k1) p +mkNest k NoDoc = NoDoc +mkNest k Empty = Empty +mkNest 0 p = p -- Worth a try! +mkNest k p = nest_ k p + +-- mkUnion checks for an empty document +mkUnion Empty q = Empty +mkUnion p q = p `union_` q \end{code} -@ppCat@ is the name I (WDP) happen to have been using for @ppBesidesSP@. +********************************************************* +* * +\subsection{Vertical composition @$$@} +* * +********************************************************* + \begin{code} -ppCat [] = ppNil -ppCat ps = foldr1 ppBesideSP ps +p $$ q = Above p False q +p $+$ q = Above p True q + +above :: Doc -> Bool -> RDoc -> RDoc +above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2) +above p@(Beside _ _ _) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q) +above p g q = aboveNest p g 0 (reduceDoc q) + +aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc +-- Specfication: aboveNest p g k q = p $g$ (nest k q) + +aboveNest NoDoc g k q = NoDoc +aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` + aboveNest p2 g k q + +aboveNest Empty g k q = mkNest k q +aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) + -- p can't be Empty, so no need for mkNest + +aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) +aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest + where + k1 = k - sl + rest = case p of + Empty -> nilAboveNest g k1 q + other -> aboveNest p g k1 q \end{code} \begin{code} -ppAbove p1 p2 width is_vert - = case (p1 width True) of - MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> - MkPrettyRep (seq1 `cAppend` (nl `cAppend` seq2)) - (MkDelay ll2) - -- ToDo: make ll depend on empties? - (emp1 && emp2) - False - where -- NB: for case alt - nl = if emp1 || emp2 then cNil else cNL - seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 - MkDelay ll2 = x_ll2 -- Don't "optimise" this away! - MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 width True - -- ToDo: ditto about passing is_vert if empties - -ppAboves [] = ppNil -ppAboves ps = foldr1 ppAbove ps +nilAboveNest :: Bool -> Int -> RDoc -> RDoc +-- Specification: text s <> nilaboveNest g k q +-- = text s <> (text "" $g$ nest k q) + +nilAboveNest g k Empty = Empty -- Here's why the "text s <>" is in the spec! +nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q + +nilAboveNest g k q | (not g) && (k > 0) -- No newline if no overlap + = textBeside_ (Str (spaces k)) k q + | otherwise -- Put them really above + = nilAbove_ (mkNest k q) +\end{code} + + +********************************************************* +* * +\subsection{Horizontal composition @<>@} +* * +********************************************************* + +\begin{code} +p <> q = Beside p False q +p <+> q = Beside p True q + +beside :: Doc -> Bool -> RDoc -> RDoc +-- Specification: beside g p q = p <g> q + +beside NoDoc g q = NoDoc +beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q) +beside Empty g q = q +beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty +beside p@(Beside p1 g1 q1) g2 q2 + {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2 + [ && (op1 == <> || op1 == <+>) ] -} + | g1 == g2 = beside p1 g1 (beside q1 g2 q2) + | otherwise = beside (reduceDoc p) g2 q2 +beside p@(Above _ _ _) g q = beside (reduceDoc p) g q +beside (NilAbove p) g q = nilAbove_ (beside p g q) +beside (TextBeside s sl p) g q = textBeside_ s sl rest + where + rest = case p of + Empty -> nilBeside g q + other -> beside p g q \end{code} \begin{code} -ppNest n p width False = p width False -ppNest n p width True - = case (p (width-n) True) of - MkPrettyRep seq (MkDelay ll) emp sl -> - MkPrettyRep (cIndent n seq) (MkDelay (ll+n)) emp sl +nilBeside :: Bool -> RDoc -> RDoc +-- Specification: text "" <> nilBeside g p +-- = text "" <g> p + +nilBeside g Empty = Empty -- Hence the text "" in the spec +nilBeside g (Nest _ p) = nilBeside g p +nilBeside g p | g = textBeside_ space_text 1 p + | otherwise = p \end{code} -The length-check below \tr{(ll1+ll2+1) <= width} should really check for -max widths not the width of the last line. +********************************************************* +* * +\subsection{Separate, @sep@, Hughes version} +* * +********************************************************* \begin{code} -ppHang p1 n p2 width is_vert -- This is a little bit stricter than it could - -- be made with a little more effort. - -- Eg the output always starts with seq1 - = case (p1 width False) of - MkPrettyRep seq1 (MkDelay ll1) emp1 sl1 -> - if emp1 then - p2 width is_vert - else - if (ll1 <= n) || sl2 then -- very ppBesideSP'ish - -- Hang it if p1 shorter than indent or if it doesn't fit - MkPrettyRep (seq1 `cAppend` ((cCh ' ') `cAppend` (cIndent (ll1+1) seq2))) - (MkDelay (ll1 + 1 + ll2)) - False - (sl1 && sl2) - else - -- Nest it (pretty ppAbove-ish) - MkPrettyRep (seq1 `cAppend` (cNL `cAppend` (cIndent n seq2'))) - (MkDelay ll2') -- ToDo: depend on empties - False - False - where -- NB: for case alt - seq2 = forceInfo x_ll2 emp2 sl2 x_seq2 - MkDelay ll2 = x_ll2 - MkPrettyRep x_seq2 x_ll2 emp2 sl2 = p2 (width-(ll1+1)) False - -- ToDo: more "is_vert if empty" stuff - - seq2' = forceInfo x_ll2' emp2' sl2' x_seq2' - MkDelay ll2' = x_ll2' -- Don't "optimise" this away! - MkPrettyRep x_seq2' x_ll2' emp2' sl2' = p2 (width-n) False -- ToDo: True? +-- Specification: sep ps = oneLiner (hsep ps) +-- `union` +-- vcat ps + +sep = sepX True -- Separate with spaces +cat = sepX False -- Don't + +sepX x [] = empty +sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps + + +-- Specification: sep1 g k ys = sep (x : map (nest k) ys) +-- = oneLiner (x <g> nest k (hsep ys)) +-- `union` x $$ nest k (vcat ys) + +sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc +sep1 g NoDoc k ys = NoDoc +sep1 g (p `Union` q) k ys = sep1 g p k ys + `union_` + (aboveNest q False k (reduceDoc (vcat ys))) + +sep1 g Empty k ys = mkNest k (sepX g ys) +sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) + +sep1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys))) +sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) + +-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys +-- Called when we have already found some text in the first item +-- We have to eat up nests + +sepNB g (Nest _ p) k ys = sepNB g p k ys + +sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest)) + `mkUnion` + nilAboveNest False k (reduceDoc (vcat ys)) + where + rest | g = hsep ys + | otherwise = hcat ys + +sepNB g p k ys = sep1 g p k ys \end{code} +********************************************************* +* * +\subsection{@fill@} +* * +********************************************************* + \begin{code} -ppSep [] width is_vert = ppNil width is_vert -ppSep [p] width is_vert = p width is_vert - --- CURRENT, but BAD. Quadratic behaviour on the perfectly reasonable --- ppSep [a, ppSep[b, ppSep [c, ... ]]] - -ppSep ps width is_vert - = case (ppCat ps width is_vert) of - MkPrettyRep seq x_ll emp sl -> - if sl then -- Fits on one line - MkPrettyRep seq x_ll emp sl - else - ppAboves ps width is_vert -- Takes several lines +fsep = fill True +fcat = fill False + +-- Specification: +-- fill [] = empty +-- fill [p] = p +-- fill (p1:p2:ps) = oneLiner p1 <#> nest (length p1) +-- (fill (oneLiner p2 : ps)) +-- `union` +-- p1 $$ fill ps + +fill g [] = empty +fill g (p:ps) = fill1 g (reduceDoc p) 0 ps + + +fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc +fill1 g NoDoc k ys = NoDoc +fill1 g (p `Union` q) k ys = fill1 g p k ys + `union_` + (aboveNest q False k (fill g ys)) + +fill1 g Empty k ys = mkNest k (fill g ys) +fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) + +fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys)) +fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys) + +fillNB g (Nest _ p) k ys = fillNB g p k ys +fillNB g Empty k [] = Empty +fillNB g Empty k (y:ys) = nilBeside g (fill1 g (oneLiner (reduceDoc y)) k1 ys) + `mkUnion` + nilAboveNest False k (fill g (y:ys)) + where + k1 | g = k - 1 + | otherwise = k + +fillNB g p k ys = fill1 g p k ys \end{code} -@speakNth@ converts an integer to a verbal index; eg 1 maps to -``first'' etc. +********************************************************* +* * +\subsection{Selecting the best layout} +* * +********************************************************* \begin{code} -speakNth :: Int -> Pretty - -speakNth 1 = ppStr "first" -speakNth 2 = ppStr "second" -speakNth 3 = ppStr "third" -speakNth 4 = ppStr "fourth" -speakNth 5 = ppStr "fifth" -speakNth 6 = ppStr "sixth" -speakNth n = ppBesides [ ppInt n, ppStr st_nd_rd_th ] +best :: Mode + -> Int -- Line length + -> Int -- Ribbon length + -> RDoc + -> RDoc -- No unions in here! + +best OneLineMode w r p + = get p where - st_nd_rd_th | n_rem_10 == 1 = "st" - | n_rem_10 == 2 = "nd" - | n_rem_10 == 3 = "rd" - | otherwise = "th" - - n_rem_10 = n `rem` 10 + get Empty = Empty + get NoDoc = NoDoc + get (NilAbove p) = nilAbove_ (get p) + get (TextBeside s sl p) = textBeside_ s sl (get p) + get (Nest k p) = get p -- Elide nest + get (p `Union` q) = first (get p) (get q) + +best mode w r p + = get w p + where + get :: Int -- (Remaining) width of line + -> Doc -> Doc + get w Empty = Empty + get w NoDoc = NoDoc + get w (NilAbove p) = nilAbove_ (get w p) + get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p) + get w (Nest k p) = nest_ k (get (w - k) p) + get w (p `Union` q) = nicest w r (get w p) (get w q) + + get1 :: Int -- (Remaining) width of line + -> Int -- Amount of first line already eaten up + -> Doc -- This is an argument to TextBeside => eat Nests + -> Doc -- No unions in here! + + get1 w sl Empty = Empty + get1 w sl NoDoc = NoDoc + get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) + get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p) + get1 w sl (Nest k p) = get1 w sl p + get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) + (get1 w sl q) + +nicest w r p q = nicest1 w r 0 p q +nicest1 w r sl p q | fits ((w `minn` r) - sl) p = p + | otherwise = q + +fits :: Int -- Space available + -> Doc + -> Bool -- True if *first line* of Doc fits in space available + +fits n p | n < 0 = False +fits n NoDoc = False +fits n Empty = True +fits n (NilAbove _) = True +fits n (TextBeside _ sl p) = fits (n - sl) p + +minn x y | x < y = x + | otherwise = y \end{code} +@first@ and @nonEmptySet@ are similar to @nicest@ and @fits@, only simpler. +@first@ returns its first argument if it is non-empty, otherwise its second. + +\begin{code} +first p q | nonEmptySet p = p + | otherwise = q + +nonEmptySet NoDoc = False +nonEmptySet (p `Union` q) = True +nonEmptySet Empty = True +nonEmptySet (NilAbove p) = True -- NoDoc always in first line +nonEmptySet (TextBeside _ _ p) = nonEmptySet p +nonEmptySet (Nest _ p) = nonEmptySet p +\end{code} -%************************************************************************ -%* * -\subsection[Outputable-print]{Pretty-printing stuff} -%* * -%************************************************************************ +@oneLiner@ returns the one-line members of the given set of @Doc@s. \begin{code} -#if defined(COMPILING_GHC) - -- to the end of file +oneLiner :: Doc -> Doc +oneLiner NoDoc = NoDoc +oneLiner Empty = Empty +oneLiner (NilAbove p) = NoDoc +oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p) +oneLiner (Nest k p) = nest_ k (oneLiner p) +oneLiner (p `Union` q) = oneLiner p +\end{code} -prettyToUn :: Pretty -> Unpretty -prettyToUn p - = case (p 999999{-totally bogus width-} False{-also invented-}) of - MkPrettyRep seq ll emp sl -> seq -#endif {-COMPILING_GHC-} -\end{code} +********************************************************* +* * +\subsection{Displaying the best layout} +* * +********************************************************* + ------------------------------------ \begin{code} --- from Lennart -fromRationalX :: (RealFloat a) => Rational -> a - -fromRationalX r = - let - h = ceiling (huge `asTypeOf` x) - b = toInteger (floatRadix x) - x = fromRat 0 r - fromRat e0 r' = - let d = denominator r' - n = numerator r' - in if d > h then - let e = integerLogBase b (d `div` h) + 1 - in fromRat (e0-e) (n % (d `div` (b^e))) - else if abs n > h then - let e = integerLogBase b (abs n `div` h) + 1 - in fromRat (e0+e) ((n `div` (b^e)) % d) - else - scaleFloat e0 (fromRational r') - in x - --- Compute the discrete log of i in base b. --- Simplest way would be just divide i by b until it's smaller then b, but that would --- be very slow! We are just slightly more clever. -integerLogBase :: Integer -> Integer -> Int -integerLogBase b i = - if i < b then - 0 - else - -- Try squaring the base first to cut down the number of divisions. - let l = 2 * integerLogBase (b*b) i - - doDiv :: Integer -> Int -> Int - doDiv j k = if j < b then k else doDiv (j `div` b) (k+1) - in - doDiv (i `div` (b^l)) l - - ------------- - --- Compute smallest and largest floating point values. {- -tiny :: (RealFloat a) => a -tiny = - let (l, _) = floatRange x - x = encodeFloat 1 (l-1) - in x +renderStyle Style{mode, lineLength, ribbonsPerLine} doc + = fullRender mode lineLength ribbonsPerLine doc "" -} -huge :: (RealFloat a) => a -huge = - let (_, u) = floatRange x - d = floatDigits x - x = encodeFloat (floatRadix x ^ d - 1) (u - d) - in x +render doc = showDoc doc "" +showDoc doc rest = fullRender PageMode 100 1.5 string_txt rest doc + +string_txt (Chr c) s = c:s +string_txt (Str s1) s2 = s1 ++ s2 +string_txt (PStr s1) s2 = s1 ++ s2 +\end{code} + +\begin{code} + +fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc) +fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc) + +fullRender mode line_length ribbons_per_line txt end doc + = display mode line_length ribbon_length txt end best_doc + where + best_doc = best mode hacked_line_length ribbon_length (reduceDoc doc) + + hacked_line_length, ribbon_length :: Int + ribbon_length = round (fromIntegral line_length / ribbons_per_line) + hacked_line_length = case mode of { ZigZagMode -> maxBound; other -> line_length } + +display mode page_width ribbon_width txt end doc + = case page_width - ribbon_width of { gap_width -> + case gap_width `quot` 2 of { shift -> + let + lay k (Nest k1 p) = lay (k + k1) p + lay k Empty = end + + lay k (NilAbove p) = nl_text `txt` lay k p + + lay k (TextBeside s sl p) + = case mode of + ZigZagMode | k >= gap_width + -> nl_text `txt` ( + Str (multi_ch shift '/') `txt` ( + nl_text `txt` ( + lay1 (k - shift) s sl p))) + + | k < 0 + -> nl_text `txt` ( + Str (multi_ch shift '\\') `txt` ( + nl_text `txt` ( + lay1 (k + shift) s sl p ))) + + other -> lay1 k s sl p + + lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p) + + lay2 k (NilAbove p) = nl_text `txt` lay k p + lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p) + lay2 k (Nest _ p) = lay2 k p + lay2 k Empty = end + in + lay 0 doc + }} + +cant_fail = error "easy_display: NoDoc" +easy_display nl_text txt end doc + = lay doc cant_fail + where + lay NoDoc no_doc = no_doc + lay (Union p q) no_doc = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc + lay (Nest k p) no_doc = lay p no_doc + lay Empty no_doc = end + lay (NilAbove p) no_doc = nl_text `txt` lay p cant_fail -- NoDoc always on first line + lay (TextBeside s sl p) no_doc = s `txt` lay p no_doc + +indent n | n >= 8 = '\t' : indent (n - 8) + | otherwise = spaces n + +multi_ch 0 ch = "" +multi_ch n ch = ch : multi_ch (n - 1) ch + +spaces 0 = "" +spaces n = ' ' : spaces (n - 1) \end{code} + diff --git a/ghc/lib/std/PrelErr.lhs b/ghc/lib/std/PrelErr.lhs index e80176d3c8..0a431f0b77 100644 --- a/ghc/lib/std/PrelErr.lhs +++ b/ghc/lib/std/PrelErr.lhs @@ -29,7 +29,7 @@ module PrelErr , error -- :: String -> a , ioError -- :: String -> a - , assert__ -- :: String -> Bool -> a -> a + , assertError -- :: String -> Bool -> a -> a ) where --import Prelude @@ -145,8 +145,8 @@ recConError s = error (untangle s "Missing field in record construction:") recUpdError s = error (untangle s "Record to doesn't contain field(s) to be updated") -assert__ :: String -> Bool -> a -> a -assert__ str pred v +assertError :: String -> Bool -> a -> a +assertError str pred v | pred = v | otherwise = error (untangle str "Assertion failed") diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot index b38406087c..0643ba62a3 100644 --- a/ghc/lib/std/PrelGHC.hi-boot +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -17,6 +17,9 @@ PrelGHC Void -- void CAF is defined in PrelBase +-- Magical assert thingy + assert__ + -- I/O primitives RealWorld realWorld# diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index bfb5affec3..763ebc48e4 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -477,6 +477,7 @@ hSetBuffering handle mode = isMarked (WriteHandle fp m b) = b isMarked (AppendHandle fp m b) = b isMarked (ReadWriteHandle fp m b) = b + isMarked _ = False bsize :: Int bsize = case mode of |