Commit e0befe92 authored by partain's avatar partain
Browse files

[project @ 1996-01-22 18:37:39 by partain]

After Andy Gill's late-95 changes
parent 68a1f023
......@@ -840,7 +840,7 @@ compile(envs/TCE,lhs,)
compile(envs/TVE,lhs,)
compile_rec(envs/TyVarEnv,lhs,)
compile(main/CmdLineOpts,lhs,-K2m)
compile(main/CmdLineOpts,lhs,-K2m if_ghc(-fvia-C))
compile_rec(main/Errors,lhs,)
compile_rec(main/ErrsTc,lhs,-H20m if_ghc26(-monly-4-regs))
compile_rec(main/ErrsRn,lhs,)
......
......@@ -18,7 +18,9 @@ absentErrorIdKey :: Unique
addrDataConKey :: Unique
addrPrimTyConKey :: Unique
addrTyConKey :: Unique
appendIdKey :: Unique
arrayPrimTyConKey :: Unique
augmentIdKey :: Unique
binaryClassKey :: Unique
boolTyConKey :: Unique
buildDataConKey :: Unique
......@@ -159,6 +161,7 @@ u2i :: Unique -> Int#
uniqSupply_u :: UniqueSupply
unpackCString2IdKey :: Unique
unpackCStringAppendIdKey :: Unique
unpackCStringFoldrIdKey :: Unique
unpackCStringIdKey :: Unique
unpkUnifiableTyVarUnique :: Unique -> Int
voidPrimIdKey :: Unique
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[Unique]{The @Unique@ data type and a (monadic) supply thereof}
......@@ -150,7 +150,13 @@ module Unique (
textClassKey,
traceIdKey,
trueDataConKey,
unpackCStringIdKey, unpackCString2IdKey, unpackCStringAppendIdKey,
unpackCString2IdKey,
unpackCStringAppendIdKey,
unpackCStringFoldrIdKey,
unpackCStringIdKey,
augmentIdKey,
appendIdKey,
--NO: rangeComplaintIdKey,
packCStringIdKey,
integerZeroIdKey, integerPlusOneIdKey,
integerPlusTwoIdKey, integerMinusOneIdKey,
......@@ -611,41 +617,42 @@ mkPrimOpIdUnique op = mkUnique '5' IBOX((tagOf_PrimOp op))
Now for other non-@DataCon@ @Ids@:
\begin{code}
absentErrorIdKey = mkPreludeMiscIdUnique 1
buildIdKey = mkPreludeMiscIdUnique 2
errorIdKey = mkPreludeMiscIdUnique 3
foldlIdKey = mkPreludeMiscIdUnique 4
foldrIdKey = mkPreludeMiscIdUnique 5
forkIdKey = mkPreludeMiscIdUnique 6
int2IntegerIdKey = mkPreludeMiscIdUnique 7
integerMinusOneIdKey = mkPreludeMiscIdUnique 8
integerPlusOneIdKey = mkPreludeMiscIdUnique 9
integerZeroIdKey = mkPreludeMiscIdUnique 10
integerPlusTwoIdKey = mkPreludeMiscIdUnique 11
packCStringIdKey = mkPreludeMiscIdUnique 12
parIdKey = mkPreludeMiscIdUnique 13
parErrorIdKey = mkPreludeMiscIdUnique 14
patErrorIdKey = mkPreludeMiscIdUnique 15
--UNUSED:readParenIdKey = mkPreludeMiscIdUnique 16
realWorldPrimIdKey = mkPreludeMiscIdUnique 17
runSTIdKey = mkPreludeMiscIdUnique 18
seqIdKey = mkPreludeMiscIdUnique 19
--UNUSED:showParenIdKey = mkPreludeMiscIdUnique 20
--UNUSED:showSpaceIdKey = mkPreludeMiscIdUnique 21
traceIdKey = mkPreludeMiscIdUnique 22
unpackCStringIdKey = mkPreludeMiscIdUnique 23
unpackCString2IdKey = mkPreludeMiscIdUnique 20 -- NB: NB: NB
unpackCStringAppendIdKey= mkPreludeMiscIdUnique 21 -- NB: NB: NB
voidPrimIdKey = mkPreludeMiscIdUnique 24
appendIdKey = mkPreludeMiscIdUnique 2
augmentIdKey = mkPreludeMiscIdUnique 3
buildIdKey = mkPreludeMiscIdUnique 4
errorIdKey = mkPreludeMiscIdUnique 5
foldlIdKey = mkPreludeMiscIdUnique 6
foldrIdKey = mkPreludeMiscIdUnique 7
forkIdKey = mkPreludeMiscIdUnique 8
int2IntegerIdKey = mkPreludeMiscIdUnique 9
integerMinusOneIdKey = mkPreludeMiscIdUnique 10
integerPlusOneIdKey = mkPreludeMiscIdUnique 11
integerPlusTwoIdKey = mkPreludeMiscIdUnique 12
integerZeroIdKey = mkPreludeMiscIdUnique 13
packCStringIdKey = mkPreludeMiscIdUnique 14
parErrorIdKey = mkPreludeMiscIdUnique 15
parIdKey = mkPreludeMiscIdUnique 16
patErrorIdKey = mkPreludeMiscIdUnique 25
--NO:rangeComplaintIdKey = mkPreludeMiscIdUnique 17
realWorldPrimIdKey = mkPreludeMiscIdUnique 18
runSTIdKey = mkPreludeMiscIdUnique 19
seqIdKey = mkPreludeMiscIdUnique 20
traceIdKey = mkPreludeMiscIdUnique 21
unpackCString2IdKey = mkPreludeMiscIdUnique 22
unpackCStringAppendIdKey= mkPreludeMiscIdUnique 23
unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 24
unpackCStringIdKey = mkPreludeMiscIdUnique 25
voidPrimIdKey = mkPreludeMiscIdUnique 26
#ifdef GRAN
parLocalIdKey = mkPreludeMiscIdUnique 25
parGlobalIdKey = mkPreludeMiscIdUnique 26
noFollowIdKey = mkPreludeMiscIdUnique 27
copyableIdKey = mkPreludeMiscIdUnique 28
parLocalIdKey = mkPreludeMiscIdUnique 27
parGlobalIdKey = mkPreludeMiscIdUnique 28
noFollowIdKey = mkPreludeMiscIdUnique 29
copyableIdKey = mkPreludeMiscIdUnique 30
#endif
#ifdef DPH
podSelectorIdKey = mkPreludeMiscIdUnique 29
podSelectorIdKey = mkPreludeMiscIdUnique 31
#endif {- Data Parallel Haskell -}
\end{code}
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CoreUtils]{Utility functions}
......@@ -56,7 +56,7 @@ import Pretty
import AbsPrel ( mkFunTy, trueDataCon, falseDataCon,
eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
buildId,
buildId, augmentId,
boolTyCon, fragilePrimOp,
PrimOp(..), typeOfPrimOp,
PrimKind
......@@ -862,7 +862,9 @@ exprSmallEnoughToDup (CoLit lit) = not (isNoRepLit lit)
exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
= case (collectArgs expr) of { (fun, args) ->
case fun of
CoVar v -> v /= buildId && length args <= 6 -- or 10 or 1 or 4 or anything smallish.
CoVar v -> v /= buildId
&& v /= augmentId
&& length args <= 6 -- or 10 or 1 or 4 or anything smallish.
_ -> False
}
\end{code}
......
......@@ -8,7 +8,7 @@ data GlobalSwitch
= ProduceC [Char] | ProduceS [Char] | ProduceHi [Char] | AsmTarget [Char] | ForConcurrent | Haskell_1_3 | GlasgowExts | CompilingPrelude | HideBuiltinNames | HideMostBuiltinNames | EnsureSplittableC [Char] | Verbose | PprStyle_User | PprStyle_Debug | PprStyle_All | DoCoreLinting | EmitArityChecks | OmitInterfacePragmas | OmitDerivedRead | OmitReexportedInstances | UnfoldingUseThreshold Int | UnfoldingCreationThreshold Int | UnfoldingOverrideThreshold Int | ReportWhyUnfoldingsDisallowed | UseGetMentionedVars | ShowPragmaNameErrs | NameShadowingNotOK | SigsRequired | SccProfilingOn | AutoSccsOnExportedToplevs | AutoSccsOnAllToplevs | AutoSccsOnIndividualCafs | SccGroup [Char] | DoTickyProfiling | DoSemiTagging | FoldrBuildOn | FoldrBuildTrace | SpecialiseImports | ShowImportSpecs | OmitDefaultInstanceMethods | SpecialiseOverloaded | SpecialiseUnboxed | SpecialiseAll | SpecialiseTrace | OmitBlackHoling | StgDoLetNoEscapes | IgnoreStrictnessPragmas | IrrefutableTuples | IrrefutableEverything | AllStrict | NumbersStrict | AllDemanded | ReturnInRegsThreshold Int | VectoredReturnThreshold Int | D_dump_rif2hs | D_dump_rn4 | D_dump_tc | D_dump_deriv | D_dump_ds | D_dump_occur_anal | D_dump_simpl | D_dump_spec | D_dump_stranal | D_dump_deforest | D_dump_stg | D_dump_absC | D_dump_flatC | D_dump_realC | D_dump_asm | D_show_passes | D_verbose_core2core | D_verbose_stg2stg | D_simplifier_stats | D_source_stats
type MainIO a = _State _RealWorld -> (a, _State _RealWorld)
data Labda a
data SimplifierSwitch = SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings | SimplNoLetFromCase | SimplNoLetFromApp | SimplNoLetFromStrictLet
data SimplifierSwitch = SimplOkToDupCode | SimplFloatLetsExposingWHNF | SimplOkToFloatPrimOps | SimplAlwaysFloatLetsFromLets | SimplDoCaseElim | SimplReuseCon | SimplCaseOfCase | SimplLetToCase | SimplMayDeleteConjurableIds | SimplPedanticBottoms | SimplDoArityExpand | SimplDoFoldrBuild | SimplDoNewOccurAnal | SimplDoInlineFoldrBuild | IgnoreINLINEPragma | SimplDoLambdaEtaExpansion | SimplDoEtaReduction | EssentialUnfoldingsOnly | ShowSimplifierProgress | MaxSimplifierIterations Int | SimplUnfoldingUseThreshold Int | SimplUnfoldingCreationThreshold Int | KeepSpecPragmaIds | KeepUnusedBindings | SimplNoLetFromCase | SimplNoLetFromApp | SimplNoLetFromStrictLet | SimplDontFoldBackAppend
data StgToDo = StgDoStaticArgs | StgDoUpdateAnalysis | StgDoLambdaLift | StgDoMassageForProfiling | D_stg_stats
data SwitchResult = SwBool Bool | SwString [Char] | SwInt Int
classifyOpts :: [[Char]] -> _State _RealWorld -> ((GlobalSwitch -> SwitchResult, [CoreToDo], [StgToDo]), _State _RealWorld)
......
......@@ -276,6 +276,17 @@ data SimplifierSwitch
| SimplNoLetFromCase -- used when turning off floating entirely
| SimplNoLetFromApp -- (for experimentation only) WDP 95/10
| SimplNoLetFromStrictLet
| SimplDontFoldBackAppend
-- we fold `foldr (:)' back into flip (++),
-- but we *don't* want to do it when compiling
-- List.hs, otherwise
-- xs ++ ys = foldr (:) ys xs
-- {- via our loopback -}
-- xs ++ ys = xs ++ ys
-- Oops!
-- So only use this flag inside List.hs
-- (Sigh, what a HACK, Andy. WDP 96/01)
{-
| Extra__SimplFlag1
| Extra__SimplFlag2
......@@ -609,6 +620,7 @@ classifyOpts opts
"-fdo-eta-reduction" -> GLOBAL_SIMPL_SW(SimplDoEtaReduction)
"-fdo-lambda-eta-expansion" -> GLOBAL_SIMPL_SW(SimplDoLambdaEtaExpansion)
"-fdo-foldr-build" -> GLOBAL_SIMPL_SW(SimplDoFoldrBuild)
"-fdo-not-fold-back-append" -> GLOBAL_SIMPL_SW(SimplDontFoldBackAppend)
"-fdo-new-occur-anal" -> GLOBAL_SIMPL_SW(SimplDoNewOccurAnal)
"-fdo-arity-expand" -> GLOBAL_SIMPL_SW(SimplDoArityExpand)
"-fdo-inline-foldr-build" -> GLOBAL_SIMPL_SW(SimplDoInlineFoldrBuild)
......@@ -790,6 +802,7 @@ tagOf_SimplSwitch KeepUnusedBindings = ILIT(25)
tagOf_SimplSwitch SimplNoLetFromCase = ILIT(26)
tagOf_SimplSwitch SimplNoLetFromApp = ILIT(27)
tagOf_SimplSwitch SimplNoLetFromStrictLet = ILIT(28)
tagOf_SimplSwitch SimplDontFoldBackAppend = ILIT(29)
-- If you add anything here, be sure to change lAST_SIMPL_SWITCH_TAG, too!
{-
......@@ -805,7 +818,7 @@ tagOf_SimplSwitch Extra__SimplFlag8 = ILIT(32)
tagOf_SimplSwitch _ = case (panic "tagOf_SimplSwitch") of -- BUG avoidance
s -> tagOf_SimplSwitch s
lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplNoLetFromStrictLet)
lAST_SIMPL_SWITCH_TAG = IBOX(tagOf_SimplSwitch SimplDontFoldBackAppend)
\end{code}
%************************************************************************
......
......@@ -11,7 +11,7 @@ import NameTypes(FullName, ShortName)
import Outputable(NamedThing, Outputable)
import PlainCore(PlainCoreExpr(..))
import PrelFuns(gLASGOW_MISC, gLASGOW_ST, pRELUDE, pRELUDE_BUILTIN, pRELUDE_CORE, pRELUDE_IO, pRELUDE_LIST, pRELUDE_PRIMIO, pRELUDE_PS, pRELUDE_RATIO, pRELUDE_TEXT)
import PrelVals(aBSENT_ERROR_ID, buildId, eRROR_ID, foldlId, foldrId, integerMinusOneId, integerPlusOneId, integerPlusTwoId, integerZeroId, mkBuild, mkFoldl, mkFoldr, pAT_ERROR_ID, packStringForCId, realWorldPrimId, unpackCString2Id, unpackCStringAppendId, unpackCStringId, voidPrimId)
import PrelVals(aBSENT_ERROR_ID, appendId, augmentId, buildId, eRROR_ID, foldlId, foldrId, integerMinusOneId, integerPlusOneId, integerPlusTwoId, integerZeroId, mkBuild, mkFoldl, mkFoldr, pAT_ERROR_ID, packStringForCId, realWorldPrimId, unpackCString2Id, unpackCStringAppendId, unpackCStringFoldrId, unpackCStringId, voidPrimId)
import PreludePS(_PackedString)
import Pretty(PprStyle, PrettyRep)
import PrimKind(PrimKind)
......@@ -51,6 +51,8 @@ pRELUDE_PS :: _PackedString
pRELUDE_RATIO :: _PackedString
pRELUDE_TEXT :: _PackedString
aBSENT_ERROR_ID :: Id
appendId :: Id
augmentId :: Id
buildId :: Id
eRROR_ID :: Id
foldlId :: Id
......@@ -112,6 +114,7 @@ packStringForCId :: Id
realWorldPrimId :: Id
unpackCString2Id :: Id
unpackCStringAppendId :: Id
unpackCStringFoldrId :: Id
unpackCStringId :: Id
voidPrimId :: Id
pprPrimOp :: PprStyle -> PrimOp -> Int -> Bool -> PrettyRep
......
......@@ -29,7 +29,9 @@ module AbsPrel (
-- *odd* values that need to be reached out and grabbed:
eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID,
unpackCStringId, unpackCString2Id, packStringForCId, unpackCStringAppendId,
packStringForCId,
unpackCStringId, unpackCString2Id,
unpackCStringAppendId, unpackCStringFoldrId,
integerZeroId, integerPlusOneId,
integerPlusTwoId, integerMinusOneId,
......@@ -99,7 +101,8 @@ module AbsPrel (
-- packedStringTyCon, packedStringTy, psDataCon, cpsDataCon,
-- for compilation of List Comprehensions and foldr
foldlId, foldrId, mkFoldl, mkFoldr, mkBuild, buildId,
foldlId, foldrId, mkFoldl, mkFoldr,
mkBuild, buildId, augmentId, appendId,
#ifdef DPH
mkProcessorTy,
......@@ -257,10 +260,15 @@ totally_wired_in_Ids
(SLIT("parError#"), WiredInVal pAR_ERROR_ID), -- ditto
(SLIT("_trace"), WiredInVal tRACE_ID),
-- now the build / foldr Id, which needs to be built in
-- now the foldr/build Ids, which need to be built in
-- because they have magic unfoldings
(SLIT("_build"), WiredInVal buildId),
(SLIT("_augment"), WiredInVal augmentId),
(SLIT("foldl"), WiredInVal foldlId),
(SLIT("foldr"), WiredInVal foldrId),
(SLIT("unpackAppendPS#"), WiredInVal unpackCStringAppendId),
(SLIT("unpackFoldrPS#"), WiredInVal unpackCStringFoldrId),
(SLIT("_runST"), WiredInVal runSTId),
(SLIT("_seq_"), WiredInVal seqId), -- yes, used in sequential-land, too
-- WDP 95/11
......
......@@ -7,6 +7,8 @@ import TyVar(TyVar)
import UniType(UniType)
import Unique(Unique)
aBSENT_ERROR_ID :: Id
appendId :: Id
augmentId :: Id
buildId :: Id
eRROR_ID :: Id
errorTy :: UniType
......@@ -32,6 +34,7 @@ seqId :: Id
tRACE_ID :: Id
unpackCString2Id :: Id
unpackCStringAppendId :: Id
unpackCStringFoldrId :: Id
unpackCStringId :: Id
voidPrimId :: Id
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[PrelVals]{Prelude values the compiler ``knows about''}
......@@ -114,28 +114,44 @@ int2IntegerId
--------------------------------------------------------------------
packStringForCId
= pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC")
(UniFun stringTy byteArrayPrimTy) noIdInfo
--------------------------------------------------------------------
unpackCStringId
= pcMiscPrelId unpackCStringIdKey pRELUDE_PS SLIT("unpackPS#")
= pcMiscPrelId unpackCStringIdKey pRELUDE_BUILTIN SLIT("unpackPS#")
(addrPrimTy{-a char *-} `UniFun` stringTy) noIdInfo
-- Andy says:
-- (UniFun addrPrimTy{-a char *-} stringTy) (noIdInfo `addInfo` mkArityInfo 1)
-- but I don't like wired-in IdInfos (WDP)
unpackCString2Id -- for cases when a string has a NUL in it
= pcMiscPrelId unpackCString2IdKey pRELUDE_PS SLIT("unpackPS2#")
= pcMiscPrelId unpackCString2IdKey pRELUDE_BUILTIN SLIT("unpackPS2#")
(addrPrimTy{-a char *-}
`UniFun` (intPrimTy -- length
`UniFun` stringTy)) noIdInfo
--------------------------------------------------------------------
unpackCStringAppendId
= pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackCStringAppend#")
= pcMiscPrelId unpackCStringAppendIdKey pRELUDE_BUILTIN SLIT("unpackAppendPS#")
(addrPrimTy{-a "char *" pointer-}
`UniFun` (stringTy
`UniFun` stringTy)) noIdInfo
`UniFun` stringTy)) ((noIdInfo
`addInfo_UF` mkMagicUnfolding SLIT("unpackAppendPS#"))
`addInfo` mkArityInfo 2)
--------------------------------------------------------------------
packStringForCId
= pcMiscPrelId packCStringIdKey{-ToDo:rename-} pRELUDE_PS SLIT("_packStringForC")
(UniFun stringTy byteArrayPrimTy) noIdInfo
unpackCStringFoldrId
= pcMiscPrelId unpackCStringFoldrIdKey pRELUDE_BUILTIN SLIT("unpackFoldrPS#")
(mkSigmaTy [alpha_tv] []
(addrPrimTy{-a "char *" pointer-}
`UniFun` ((charTy `UniFun` (alpha `UniFun` alpha))
`UniFun` (alpha
`UniFun` alpha)))) ((noIdInfo
`addInfo_UF` mkMagicUnfolding SLIT("unpackFoldrPS#"))
`addInfo` mkArityInfo 3)
\end{code}
OK, this is Will's idea: we should have magic values for Integers 0,
......@@ -502,6 +518,7 @@ runSTId
= noIdInfo
`addInfo` mkArityInfo 1
`addInfo` mkStrictnessInfo [WwStrict] Nothing
`addInfo` mkArgUsageInfo [ArgUsage 1]
-- ABSOLUTELY NO UNFOLDING, e.g.: (mkUnfolding EssentialUnfolding run_ST_template)
-- see example below
{- OUT:
......@@ -568,6 +585,23 @@ realWorldPrimId
%* *
%************************************************************************
\begin{code}
{- NO:
rangeComplaint_Ix_IntId
= pcMiscPrelId rangeComplaintIdKey pRELUDE_BUILTIN SLIT("_rangeComplaint_Ix_Int") my_ty id_info
where
my_ty
= mkSigmaTy [alpha_tv] [] (
intPrimTy `UniFun` (
intPrimTy `UniFun` (
intPrimTy `UniFun` alpha)))
id_info
= noIdInfo
`addInfo` mkArityInfo 3
`addInfo` mkBottomStrictnessInfo
-}
\end{code}
\begin{code}
buildId
= pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_build") buildTy
......@@ -614,6 +648,26 @@ mkBuild ty tv c n g expr
(CoApp (mkCoTyApp (CoVar buildId) ty) (CoVarAtom g))
\end{code}
\begin{code}
augmentId
= pcMiscPrelId buildIdKey pRELUDE_CORE SLIT("_augment") augmentTy
(((noIdInfo
`addInfo_UF` mkMagicUnfolding SLIT("augment"))
`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
`addInfo` mkArgUsageInfo [ArgUsage 2,UnknownArgUsage])
-- cheating, but since _build never actually exists ...
where
-- The type of this strange object is:
-- \/ a . (\/ b . (a -> b -> b) -> b -> b) -> [a] -> [a]
augmentTy = mkSigmaTy [alpha_tv] [] (buildUniTy `UniFun`
(mkListTy alpha `UniFun` mkListTy alpha))
where
buildUniTy = mkSigmaTy [beta_tv] []
((alpha `UniFun` (beta `UniFun` beta))
`UniFun` (beta `UniFun` beta))
\end{code}
mkFoldr ty_a ty_b [x,y...] => foldr ty_a ty_b x y ..
\begin{code}
......@@ -659,5 +713,30 @@ mkFoldl a b f z xs = foldl CoApp
(mkCoTyApps (CoVar foldlId) [a, b])
[CoVarAtom f,CoVarAtom z,CoVarAtom xs]
-- A bit of magic goes no here. We translate appendId into ++,
-- you have to be carefull when you actually compile append:
-- xs ++ ys = augment (\ c n -> foldr c n xs) ys
-- {- unfold augment -}
-- = foldr (:) ys xs
-- {- fold foldr to append -}
-- = ys `appendId` xs
-- = ys ++ xs -- ugg!
-- *BUT* you want (++) and not _append in your interfaces.
--
-- So you have to turn *off* unfolding of foldr inside FoldrBuild.hs inside
-- the prelude.
--
appendId
= pcMiscPrelId appendIdKey pRELUDE_LIST SLIT("++") appendTy idInfo
where
appendTy =
(mkSigmaTy [alpha_tv] []
((mkListTy alpha) `UniFun` ((mkListTy alpha) `UniFun` (mkListTy alpha))))
idInfo = (((noIdInfo
`addInfo` mkStrictnessInfo [WwStrict,WwLazy False] Nothing)
`addInfo` mkArityInfo 2)
`addInfo` mkUpdateInfo [1,2])
pRELUDE_FB = SLIT("PreludeFoldrBuild")
\end{code}
......@@ -20,9 +20,10 @@ module MagicUFs (
IMPORT_Trace -- ToDo: not sure why this is being used
import AbsPrel ( foldlId, foldrId, buildId,
import AbsPrel ( foldlId, foldrId, buildId, augmentId,
nilDataCon, consDataCon, mkListTy, mkFunTy,
unpackCStringAppendId
unpackCStringAppendId, unpackCStringFoldrId,
appendId
)
import AbsUniType ( splitTypeWithDictsAsArgs, TyVarTemplate )
import BasicLit ( BasicLit(..) )
......@@ -85,9 +86,12 @@ applyMagicUnfoldingFun (MUF fun) env args = fun env args
magic_UFs_table :: [(FAST_STRING, MagicUnfoldingFun)]
magic_UFs_table
= [(SLIT("build"), MUF build_fun),
(SLIT("foldl"), MUF foldl_fun),
(SLIT("foldr"), MUF foldr_fun) ]
= [(SLIT("augment"), MUF augment_fun),
(SLIT("build"), MUF build_fun),
(SLIT("foldl"), MUF foldl_fun),
(SLIT("foldr"), MUF foldr_fun),
(SLIT("unpackFoldrPS#"), MUF unpack_foldr_fun),
(SLIT("unpackAppendPS#"), MUF unpack_append_fun)]
\end{code}
%************************************************************************
......@@ -119,26 +123,48 @@ build_fun env [TypeArg ty,ValArg (CoVarAtom e)]
build_fun env _ =
ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
returnSmpl Nothing
\end{code}
-- Now foldr, the way we consume lists.
\begin{code}
augment_fun :: SimplEnv
-> [PlainCoreArg]
-> SmplM (Maybe PlainCoreExpr)
augment_fun env [TypeArg ty,ValArg (CoVarAtom e),ValArg nil]
| switchIsSet env SimplDoInlineFoldrBuild =
let
tyL = mkListTy ty
ourCons = mkCoTyApp (CoVar consDataCon) ty
in
newId (ty `mkFunTy` (tyL `mkFunTy` tyL)) `thenSmpl` \ c ->
returnSmpl (Just (CoLet (CoNonRec c ourCons)
(CoApp (CoApp (mkCoTyApp (CoVar e) tyL) (CoVarAtom c)) nil)))
-- ToDo: add `build' without an argument instance.
-- This is strange, because of g's type.
augment_fun env _ =
ASSERT (not (switchIsSet env SimplDoInlineFoldrBuild))
returnSmpl Nothing
\end{code}
Now foldr, the way we consume lists.
\begin{code}
foldr_fun :: SimplEnv
-> [PlainCoreArg]
-> SmplM (Maybe PlainCoreExpr)
{-
foldr_fun env _
| trace "HEHJDHF!" False = error "NEVER"
-}
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)
| isConsFun env arg_k && isNilForm env arg_z
| do_fb_red && isConsFun env arg_k && isNilForm env arg_z
= -- foldr (:) [] ==> id
-- this transformation is *always* benificial
-- cf. foldr (:) [] (build g) == g (:) []
-- with foldr (:) [] (build g) == build g
-- after unfolding build, they are the same thing.
tick FoldrConsNil `thenSmpl_`
tick Foldr_Cons_Nil `thenSmpl_`
newId (mkListTy ty1) `thenSmpl` \ x ->
returnSmpl({-trace "foldr (:) []"-} (Just (applyToArgs (CoLam [x] (CoVar x)) rest_args)))
where
do_fb_red = switchIsSet env SimplDoFoldrBuild
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list:rest_args)
| do_fb_red && isNilForm env arg_list
......@@ -153,20 +179,18 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
tick FoldrBuild `thenSmpl_`
returnSmpl (Just (applyToArgs (CoVar g) (TypeArg ty2:ValArg arg_k:ValArg arg_z:rest_args)))
| do_fb_red && arg_list_isAppendForm
= -- foldr k z (foldr (:) ys xs) <args> ==> foldr k (foldr k z ys) xs <args>
-- this unfolds foldr one into foldr
tick FoldrFoldr `thenSmpl_`
newId ty2 `thenSmpl` \ other_foldr ->
let
inner_foldr = applyToArgs (CoVar foldrId)
[TypeArg ty1,TypeArg ty2,
ValArg arg_k,ValArg arg_z,ValArg ys]
outer_foldr = applyToArgs (CoVar foldrId)
([TypeArg ty1,TypeArg ty2,
ValArg arg_k,ValArg (CoVarAtom other_foldr),ValArg xs]
++ rest_args)
in returnSmpl (Just (CoLet (CoNonRec other_foldr inner_foldr) outer_foldr))
| do_fb_red && arg_list_isAugmentForm
= -- foldr k z (augment g h) ==> let v = foldr k z h in g k v
-- this next line *is* the foldr/augment rule proper.
tick FoldrAugment `thenSmpl_`
newId ty2 `thenSmpl` \ v ->
returnSmpl (Just
(CoLet (CoNonRec v (applyToArgs (CoVar foldrId)
[TypeArg ty1,TypeArg ty2,
ValArg arg_k,
ValArg arg_z,
ValArg h]))
(applyToArgs (CoVar g') (TypeArg ty2:ValArg arg_k:ValArg (CoVarAtom v):rest_args))))
| do_fb_red && arg_list_isListForm
= -- foldr k z (a:b:c:rest) =
......@@ -212,26 +236,46 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:ValArg arg_z:ValArg arg_list
returnSmpl (Just (applyToArgs (CoLam [f_id] core_list)
(ValArg arg_k:rest_args)))
--
| do_fb_red && arg_list_isStringForm -- ok, its a string!
-- foldr f z "foo" => unpackFoldrPS# f z "foo"#
= tick Str_FoldrStr `thenSmpl_`
returnSmpl (Just (applyToArgs (CoVar unpackCStringFoldrId)
(TypeArg ty2:
ValArg (CoLitAtom (MachStr str_val)):
ValArg arg_k:
ValArg arg_z:
rest_args)))
where
do_fb_red = switchIsSet env SimplDoFoldrBuild
arg_list_isStringForm = maybeToBool stringForm
stringForm = getStringForm env arg_list
(Just str_val) = stringForm
arg_list_isBuildForm = maybeToBool buildForm
buildForm = getBuildForm env arg_list
(Just g) = buildForm
arg_list_isAugmentForm = maybeToBool augmentForm
augmentForm = getAugmentForm env arg_list
(Just (g',h)) = augmentForm
arg_list_isListForm = maybeToBool listForm
listForm = getListForm env arg_list
(Just (the_list,the_tl)) = listForm
{-
arg_list_isAppendForm = maybeToBool appendForm
appendForm = getAppendForm env arg_list
(Just (xs,ys)) = appendForm
-}
foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
{- OLD:
| doing_inlining && isConsFun env arg_k
| doing_inlining && isConsFun env arg_k && not dont_fold_back_append
= -- foldr (:) z xs = xs ++ z
tick FoldrCons `thenSmpl_`
tick Foldr_Cons `thenSmpl_`
newIds [ty2,mkListTy ty1] `thenSmpl` \ [z,x] ->
returnSmpl (Just (applyToArgs
(CoLam [z,x] (applyToArgs
......@@ -240,7 +284,6 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
ValArg (CoVarAtom x),
ValArg (CoVarAtom z)]))
rest_args))
-}
| doing_inlining && (isInterestingArg env arg_k
|| isConsFun env arg_k)
= -- foldr k args =
......@@ -252,7 +295,7 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
-- in
-- h xs) k args
--
tick FoldrInline `thenSmpl_`
-- tick FoldrInline `thenSmpl_`
newIds [
ty1, -- a :: t1
mkListTy ty1, -- b :: [t1]
......@@ -284,6 +327,7 @@ foldr_fun env (TypeArg ty1:TypeArg ty2:ValArg arg_k:rest_args)
(ValArg arg_k:rest_args)))
where
doing_inlining = switchIsSet env SimplDoInlineFoldrBuild
dont_fold_back_append = switchIsSet env SimplDontFoldBackAppend
foldr_fun _ _ = returnSmpl Nothing
isConsFun :: SimplEnv -> PlainCoreAtom -> Bool
......@@ -310,12 +354,34 @@ isNilForm env _ = False
getBuildForm :: SimplEnv -> PlainCoreAtom -> Maybe Id
getBuildForm env (CoVarAtom v) =
case lookupUnfolding env v of
GeneralForm False _ _ _ -> Nothing -- not allowed to inline :-(
GeneralForm False _ _ _ -> Nothing
-- not allowed to inline :-(
GeneralForm _ _ (CoApp (CoTyApp (CoVar bld) _) (CoVarAtom g)) _
| bld == buildId -> Just g
GeneralForm _ _ (CoApp (CoApp (CoTyApp (CoVar bld) _)
(CoVarAtom g)) h) _
| bld == augmentId && isNilForm env h -> Just g
_ -> Nothing
getBuildForm env _ = Nothing
getAugmentForm :: SimplEnv -> PlainCoreAtom -> Maybe (Id,PlainCoreAtom)
getAugmentForm env (CoVarAtom v) =
case lookupUnfolding env v of