From 508a505e9853984bfdaa3ad855ae3fcbc6d31787 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 27 Jan 2005 10:45:48 +0000 Subject: [PATCH] [project @ 2005-01-27 10:44:00 by simonpj] -------------------------------------------- Replace hi-boot files with hs-boot files -------------------------------------------- This major commit completely re-organises the way that recursive modules are dealt with. * It should have NO EFFECT if you do not use recursive modules * It is a BREAKING CHANGE if you do ====== Warning: .hi-file format has changed, so if you are ====== updating into an existing HEAD build, you'll ====== need to make clean and re-make The details: [documentation still to be done] * Recursive loops are now broken with Foo.hs-boot (or Foo.lhs-boot), not Foo.hi-boot * An hs-boot files is a proper source file. It is compiled just like a regular Haskell source file: ghc Foo.hs generates Foo.hi, Foo.o ghc Foo.hs-boot generates Foo.hi-boot, Foo.o-boot * hs-boot files are precisely a subset of Haskell. In particular: - they have the same import, export, and scoping rules - errors (such as kind errors) in hs-boot files are checked You do *not* need to mention the "original" name of something in an hs-boot file, any more than you do in any other Haskell module. * The Foo.hi-boot file generated by compiling Foo.hs-boot is a machine- generated interface file, in precisely the same format as Foo.hi * When compiling Foo.hs, its exports are checked for compatibility with Foo.hi-boot (previously generated by compiling Foo.hs-boot) * The dependency analyser (ghc -M) knows about Foo.hs-boot files, and generates appropriate dependencies. For regular source files it generates Foo.o : Foo.hs Foo.o : Baz.hi -- Foo.hs imports Baz Foo.o : Bog.hi-boot -- Foo.hs source-imports Bog For a hs-boot file it generates similar dependencies Bog.o-boot : Bog.hs-boot Bog.o-boot : Nib.hi -- Bog.hs-boto imports Nib * ghc -M is also enhanced to use the compilation manager dependency chasing, so that ghc -M Main will usually do the job. No need to enumerate all the source files. * The -c flag is no longer a "compiler mode". It simply means "omit the link step", and synonymous with -no-link. --- ghc/compiler/Makefile | 10 +- ghc/compiler/basicTypes/DataCon.hi-boot | Bin 221 -> 1190 bytes ghc/compiler/basicTypes/DataCon.lhs-boot | 8 + ghc/compiler/basicTypes/IdInfo.hi-boot | Bin 263 -> 429 bytes ghc/compiler/basicTypes/IdInfo.lhs-boot | 9 + ghc/compiler/basicTypes/MkId.hi-boot | Bin 151 -> 1448 bytes ghc/compiler/basicTypes/MkId.lhs-boot | 9 + ghc/compiler/basicTypes/Module.lhs | 45 ++- ghc/compiler/basicTypes/Module.lhs-boot | 6 + ghc/compiler/basicTypes/Name.hi-boot | Bin 69 -> 294 bytes ghc/compiler/basicTypes/Name.lhs-boot | 5 + ghc/compiler/basicTypes/OccName.lhs-boot | 5 + ghc/compiler/codeGen/CgBindery.hi-boot | Bin 270 -> 1407 bytes ghc/compiler/codeGen/CgBindery.lhs-boot | 11 + ghc/compiler/codeGen/CgExpr.hi-boot | Bin 109 -> 1948 bytes ghc/compiler/codeGen/CgExpr.lhs-boot | 7 + ghc/compiler/codeGen/ClosureInfo.lhs-boot | 6 + ghc/compiler/compMan/CompManager.lhs | 464 ++++++++++++++----------- ghc/compiler/deSugar/Desugar.lhs | 3 + ghc/compiler/deSugar/DsExpr.hi-boot | Bin 237 -> 3307 bytes ghc/compiler/deSugar/DsExpr.lhs-boot | 11 + ghc/compiler/deSugar/DsMonad.lhs | 72 +++- ghc/compiler/deSugar/DsUtils.lhs | 25 -- ghc/compiler/deSugar/Match.hi-boot | Bin 593 -> 3769 bytes ghc/compiler/deSugar/Match.hi-boot-6 | 8 +- ghc/compiler/deSugar/Match.lhs-boot | 35 ++ ghc/compiler/ghci/Linker.lhs | 1 - ghc/compiler/hsSyn/HsBinds.lhs | 20 +- ghc/compiler/hsSyn/HsExpr.hi-boot | Bin 484 -> 1705 bytes ghc/compiler/hsSyn/HsExpr.lhs-boot | 26 ++ ghc/compiler/hsSyn/HsPat.lhs-boot | 7 + ghc/compiler/iface/BinIface.hs | 6 +- ghc/compiler/iface/IfaceType.lhs | 7 +- ghc/compiler/iface/LoadIface.lhs | 93 ++--- ghc/compiler/iface/MkIface.lhs | 34 +- ghc/compiler/iface/TcIface.lhs-boot | 9 + ghc/compiler/main/CmdLineOpts.lhs | 35 +- ghc/compiler/main/CodeOutput.lhs | 2 +- ghc/compiler/main/DriverFlags.hs | 36 +- ghc/compiler/main/DriverMkDepend.hs | 413 +++++++++++++---------- ghc/compiler/main/DriverPhases.hs | 182 +++++++--- ghc/compiler/main/DriverPipeline.hs | 506 +++++++++++++++------------- ghc/compiler/main/DriverState.hs | 24 +- ghc/compiler/main/Finder.lhs | 345 ++++++++++--------- ghc/compiler/main/GetImports.hs | 4 +- ghc/compiler/main/HscMain.lhs | 244 ++++++++------ ghc/compiler/main/HscTypes.lhs | 77 ++++- ghc/compiler/main/Main.hs | 64 ++-- ghc/compiler/main/Packages.lhs-boot | 4 + ghc/compiler/parser/Parser.y.pp | 49 +-- ghc/compiler/parser/RdrHsSyn.lhs | 208 ------------ ghc/compiler/rename/RnBinds.lhs | 33 +- ghc/compiler/rename/RnExpr.lhs | 4 +- ghc/compiler/rename/RnNames.lhs | 21 +- ghc/compiler/rename/RnSource.lhs | 15 +- ghc/compiler/rename/RnSource.lhs-boot | 20 ++ ghc/compiler/typecheck/TcBinds.lhs | 25 +- ghc/compiler/typecheck/TcClassDcl.lhs | 2 +- ghc/compiler/typecheck/TcDeriv.lhs | 13 +- ghc/compiler/typecheck/TcExpr.hi-boot | Bin 351 -> 3273 bytes ghc/compiler/typecheck/TcExpr.hi-boot-6 | 2 +- ghc/compiler/typecheck/TcExpr.lhs-boot | 27 ++ ghc/compiler/typecheck/TcForeign.lhs | 8 +- ghc/compiler/typecheck/TcHsType.lhs | 1 + ghc/compiler/typecheck/TcMatches.hi-boot | Bin 394 -> 3064 bytes ghc/compiler/typecheck/TcMatches.hi-boot-6 | 4 +- ghc/compiler/typecheck/TcMatches.lhs-boot | 17 + ghc/compiler/typecheck/TcRnDriver.lhs | 183 +++++++--- ghc/compiler/typecheck/TcRnMonad.lhs | 15 +- ghc/compiler/typecheck/TcRnTypes.lhs | 5 +- ghc/compiler/typecheck/TcSplice.hi-boot-6 | 4 +- ghc/compiler/typecheck/TcSplice.lhs-boot | 21 ++ ghc/compiler/typecheck/TcTyClsDecls.lhs | 33 +- ghc/compiler/typecheck/TcType.hi-boot | Bin 88 -> 314 bytes ghc/compiler/typecheck/TcType.lhs | 6 +- ghc/compiler/typecheck/TcType.lhs-boot | 5 + ghc/compiler/typecheck/TcUnify.hi-boot | Bin 146 -> 2709 bytes ghc/compiler/typecheck/TcUnify.lhs | 5 +- ghc/compiler/typecheck/TcUnify.lhs-boot | 10 + ghc/compiler/types/TyCon.hi-boot | Bin 322 -> 435 bytes ghc/compiler/types/TyCon.lhs-boot | 9 + ghc/compiler/types/TypeRep.hi-boot | Bin 210 -> 388 bytes ghc/compiler/types/TypeRep.lhs-boot | 8 + ghc/docs/comm/genesis/modules.html | 15 +- ghc/utils/ghc-pkg/Main.hs | 14 +- 85 files changed, 2092 insertions(+), 1568 deletions(-) create mode 100644 ghc/compiler/basicTypes/DataCon.lhs-boot create mode 100644 ghc/compiler/basicTypes/IdInfo.lhs-boot create mode 100644 ghc/compiler/basicTypes/MkId.lhs-boot create mode 100644 ghc/compiler/basicTypes/Module.lhs-boot create mode 100644 ghc/compiler/basicTypes/Name.lhs-boot create mode 100644 ghc/compiler/basicTypes/OccName.lhs-boot create mode 100644 ghc/compiler/codeGen/CgBindery.lhs-boot create mode 100644 ghc/compiler/codeGen/CgExpr.lhs-boot create mode 100644 ghc/compiler/codeGen/ClosureInfo.lhs-boot create mode 100644 ghc/compiler/deSugar/DsExpr.lhs-boot create mode 100644 ghc/compiler/deSugar/Match.lhs-boot create mode 100644 ghc/compiler/hsSyn/HsExpr.lhs-boot create mode 100644 ghc/compiler/hsSyn/HsPat.lhs-boot create mode 100644 ghc/compiler/iface/TcIface.lhs-boot create mode 100644 ghc/compiler/main/Packages.lhs-boot create mode 100644 ghc/compiler/rename/RnSource.lhs-boot create mode 100644 ghc/compiler/typecheck/TcExpr.lhs-boot create mode 100644 ghc/compiler/typecheck/TcMatches.lhs-boot create mode 100644 ghc/compiler/typecheck/TcSplice.lhs-boot create mode 100644 ghc/compiler/typecheck/TcType.lhs-boot create mode 100644 ghc/compiler/typecheck/TcUnify.lhs-boot create mode 100644 ghc/compiler/types/TyCon.lhs-boot create mode 100644 ghc/compiler/types/TypeRep.lhs-boot diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 0a2805a..b145c60 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -86,6 +86,10 @@ WAYS=$(GhcCompilerWays) # - create a link tree. The problem with requiring link trees is that # Windows doesn't support symbolic links. +ifeq "$(stage)" "" +stage=1 +endif + boot :: $(MKDIRHIER) stage$(stage) for i in $(ALL_DIRS); do \ @@ -100,6 +104,8 @@ boot :: # PS: 'ln -s foo baz' takes 'foo' relative to the path to 'baz' # whereas 'cp foo baz' treats the two paths independently. # Hence the "../.." in the ln command line +ifeq "$(stage)" "1" +ifeq "$(ghc_ge_603)" "NO" ifeq "$(HOSTPLATFORM)" "i386-unknown-mingw32" for i in */*hi-boot*; do \ cp -u -f $$i stage$(stage)/$$i; \ @@ -109,9 +115,7 @@ else $(LN_S) -f ../../$$i stage$(stage)/$$i || true ; \ done endif - -ifeq "$(stage)" "" -stage=1 +endif endif ifeq "$(stage)" "1" diff --git a/ghc/compiler/basicTypes/DataCon.hi-boot b/ghc/compiler/basicTypes/DataCon.hi-boot index 9a19a92759e52e7dba3e3449b2df266ef3e08e56..744bd182564834c6e1fb3ebfe96dc67b01fc0e16 100644 GIT binary patch literal 1190 zcmZ9K*>clB5Jjap-sB~A!j`avea}`D6g(0Khg8|vg%fxl%Y&JUESb@W!ukpRjDO&P zpWunUJ&GWxN=LVEw?;kFa@^lP9LN3TI*#)K*ae=kB0(1<-_NZAm)I#VmzhOoiCJb= zm{q37tTF4%2D8arVYZlU=BkUYtg*hpyvV%7yv*4vtk;a_a|LeU*CnS;V}MXX6v20?K+_ z5u1KujzV)5jf_?yuZLXz{k~X?Z72O`k_1?K`JI^ISswU)CcQyo=7|wwE@%vee=4Rj zZ?TdYXuLQSq4G(ThFThft$9POW+;&p_#^H2B2<*o#d|r2c@nBG-9AjHkwo8YCfriC zuWCn(MX(NT~p5`Ln!>c}?SH~l(G=0x$~p6BK-R{8R;p+UQimeI@vPhIp$w%~evBlB z>+=lS-AGF{4XNo=osFoTn?s{%h3es3%4XlU0k%jPk2BpM5;(mINA?e}Wjz%mVS|s6 Y#x!aZ`)6i@ZmIYK%`XT9`lNOL00SV=!~g&Q literal 221 zcmZvVK?(vf3`O@nMK0jLY%RDLbuZ#Rgqa9|(v&uf@%GcIRS;K!pa0)OiN^U(Gb5bH z=%^7!hrA}uR?zjV-{sZ0a=JYdgOu|s#WuY#AeCz)e{j4sT!$gILNi{&7ZJvEgX#fBK diff --git a/ghc/compiler/basicTypes/DataCon.lhs-boot b/ghc/compiler/basicTypes/DataCon.lhs-boot new file mode 100644 index 0000000..c5e05c9 --- /dev/null +++ b/ghc/compiler/basicTypes/DataCon.lhs-boot @@ -0,0 +1,8 @@ +\begin{code} +module DataCon where +import Name( Name ) + +data DataCon +dataConName :: DataCon -> Name +isVanillaDataCon :: DataCon -> Bool +\end{code} diff --git a/ghc/compiler/basicTypes/IdInfo.hi-boot b/ghc/compiler/basicTypes/IdInfo.hi-boot index 2edaa0a416f80998ad189d0e3537272975e0350e..19cbf0ed549fa70dd6f69b0bdf8a58db52680ae8 100644 GIT binary patch literal 429 zcmYL@L2kk@6hyyCfsmxCI7ll{r5>PE&`4c$fyAa8LtJDjvLVT)oP{%S6BcY)_0P9U zE&ZpNvBx&4>xqaiitz$WfM-!GctK+5D@vFikN|f;9~b~bAO%J|q(fDygiRJm!I8Ll zH|3}h6++R+@LW%tatyH&4-uNNmJ~71;wN!W9>NTo*BQY1d!9jAmG0ZKO4qtIkJG0K z>+#$-#%|rg&JK3@vokG+#V!2o8up{bJMX@7>t<%&ZP;Y8Gq1hw*rno12OT;ew*5CN f-&DNwu&Di7*Jbr)I&Et_m^VVi2KKS%aP@p-dW5Tp9=Pq|~=; p*S)7#*I-+ZCxkzyLf_qrv=| diff --git a/ghc/compiler/basicTypes/IdInfo.lhs-boot b/ghc/compiler/basicTypes/IdInfo.lhs-boot new file mode 100644 index 0000000..90cf36f --- /dev/null +++ b/ghc/compiler/basicTypes/IdInfo.lhs-boot @@ -0,0 +1,9 @@ +\begin{code} +module IdInfo where + +data IdInfo +data GlobalIdDetails + +notGlobalId :: GlobalIdDetails +seqIdInfo :: IdInfo -> () +\end{code} \ No newline at end of file diff --git a/ghc/compiler/basicTypes/MkId.hi-boot b/ghc/compiler/basicTypes/MkId.hi-boot index 47b20fb9eb623376070e3ff2ccde6162343d418e..4fc503fda3724b6eab78835d9ea07be45efcead5 100644 GIT binary patch literal 1448 zcmZ{i>rxXz5QR77LK1=qhzj0<_ZtXaLB%Qw1XB`|B0+yoHUmy&GaF|ol*v2zYCe$u zvHQ#>h*hR4-=03*JJZuUUgFnJ&ztBbJkNW{SYtecB0)cv`2TQ|R6j%VK!E*^-Z3g;0I1A2!^WX(=0lWxa!dsW27r`a)3V0Q~23|+y4d^1c4BiB9 zfw#ds;9c+@c;6lS0eAS2@d)-~mMe@^#uEl+w$AD)1JirX>IDO1eZ^{nvB`MNc*9s= z6dB9(PyA+;W#uK3BMJ2uCWA}n5h3B^D6xP9!POPdhS-CXyuN!dw-_)c+|ZHpwvq+x z#f`XK{$pgvt$KI^@wj2SFKV>@I})jCr_!cpep^J!Zw`7gqA0Viv@iow=~5sfwx&wm z_P)}x*0ZQ6h5ASxQzAzyvO>d7mnW9y+RuLCbYt4cq;IyGVT!U363P z{aEH}ecS6>(L%v=UHBbwEXSwG#s;sLt_!Vv61lpO0l$xZD6p1ildl`q<$B58OdhmN zyho;C{QZ#M%rr4mQt9TvjU&Ye;(C4_$R1Z6YW1yLWs?;hX=L_sig;AX&%$tm9=rM^ zR<1Z#5-ky|tgo(-oo&&iV?9k%@5mt7+=z{N>cW~Z7%CEe-x!I(&yDTf@4oC=g->_t zRzoe?L)B=~`cwREhw8mCg2yoXS2$F3kGSWVGiIem*3v)LP|-J+MvH*Qy6CcdQcI)! zh?9J)e9U~d92%*PH8nj{qYF_On{~@`$?bihY`nh<_=uFrBU27S!Gp~ra`(-Z@jV(Z V@Fg_3T-*=6Uuko9g>L6G{sW1e@Ld1^ literal 151 zcma#g%qvMPN=r;mjaTr^_DoSQ Name -> DataCon -> DataConIds +\end{code} + + diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index 70e0209..d67b8a5 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -15,7 +15,7 @@ module Module , pprModule -- :: ModuleName -> SDoc , ModLocation(..), - , showModMsg + , addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn, , moduleString -- :: ModuleName -> EncodedString , moduleUserString -- :: ModuleName -> UserString @@ -30,7 +30,7 @@ module Module , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv , moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv - , extendModuleEnv_C + , extendModuleEnv_C, filterModuleEnv, , ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet @@ -40,11 +40,9 @@ module Module import OccName import Outputable import Unique ( Uniquable(..) ) -import Maybes ( expectJust ) import UniqFM import UniqSet import Binary -import StringBuffer ( StringBuffer ) import FastString \end{code} @@ -58,15 +56,9 @@ import FastString data ModLocation = ModLocation { ml_hs_file :: Maybe FilePath, - -- the source file, if we have one. Package modules + -- The source file, if we have one. Package modules -- probably don't have source files. - ml_hspp_file :: Maybe FilePath, - -- filename of preprocessed source, if we have - -- preprocessed it. - ml_hspp_buf :: Maybe StringBuffer, - -- the actual preprocessed source, maybe. - ml_hi_file :: FilePath, -- Where the .hi file is, whether or not it exists -- yet. Always of form foo.hi, even if there is an @@ -81,18 +73,6 @@ data ModLocation instance Outputable ModLocation where ppr = text . show - --- Rather a gruesome function to have in Module - -showModMsg :: Bool -> Module -> ModLocation -> String -showModMsg use_object mod location = - mod_str ++ replicate (max 0 (16 - length mod_str)) ' ' - ++" ( " ++ expectJust "showModMsg" (ml_hs_file location) ++ ", " - ++ (if use_object - then ml_obj_file location - else "interpreted") - ++ " )" - where mod_str = moduleUserString mod \end{code} For a module in another package, the hs_file and obj_file @@ -103,6 +83,23 @@ correspond to actual files yet: for example, even if the object file doesn't exist, the ModLocation still contains the path to where the object file will reside if/when it is created. +\begin{code} +addBootSuffix :: FilePath -> FilePath +-- Add the "-boot" suffix to .hs, .hi and .o files +addBootSuffix path = path ++ "-boot" + +addBootSuffix_maybe :: Bool -> FilePath -> FilePath +addBootSuffix_maybe is_boot path + | is_boot = addBootSuffix path + | otherwise = path + +addBootSuffixLocn :: ModLocation -> ModLocation +addBootSuffixLocn locn + = locn { ml_hs_file = fmap addBootSuffix (ml_hs_file locn) + , ml_hi_file = addBootSuffix (ml_hi_file locn) + , ml_obj_file = addBootSuffix (ml_obj_file locn) } +\end{code} + %************************************************************************ %* * @@ -188,7 +185,9 @@ lookupModuleEnv :: ModuleEnv a -> Module -> Maybe a lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a elemModuleEnv :: Module -> ModuleEnv a -> Bool foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b +filterModuleEnv :: (a -> Bool) -> ModuleEnv a -> ModuleEnv a +filterModuleEnv = filterUFM elemModuleEnv = elemUFM extendModuleEnv = addToUFM extendModuleEnv_C = addToUFM_C diff --git a/ghc/compiler/basicTypes/Module.lhs-boot b/ghc/compiler/basicTypes/Module.lhs-boot new file mode 100644 index 0000000..d75c032 --- /dev/null +++ b/ghc/compiler/basicTypes/Module.lhs-boot @@ -0,0 +1,6 @@ +\begin{code} +module Module where + +data Module +\end{code} + diff --git a/ghc/compiler/basicTypes/Name.hi-boot b/ghc/compiler/basicTypes/Name.hi-boot index 8c578f319eccd48722f8f9115e1379c33ff5881a..0dcc6608aaa652cf868632fd2b74eadc80187c2f 100644 GIT binary patch literal 294 zcmZQz{B@3jfnhcykT3%g1|Y&1%mOli0K^1gh8QRl#9;yv%pigVM6iMgHW0xMA~-+< zClE6vLbNh6GJ|*!62yWU*#I$;2`md01IkT@Dc}M!So{)mQ-L%`QettcuA!a*kS*wz zUzD1eo>!IWT$LG8S&&)`6y$*m29y*5`JC<^Kv^fCE;z?IKQ9@`;R4IJ<>V)p0C^l> Uo@XA24bkJ1S&ZO>=NF{_08+&$^8f$< literal 69 zcma#g%qvMPN=r;mjaTqX%uQ7=wMtlXl3SI*jkzE3>!?^+81aE=2!DaA{JIr0) z!#&1**bg{-$autf%y`0h%6P_j&RAirGF~vytaXlFGSIfy9L>|`|CmIiNV8n#!1L2I zyg}$Rk@Dj#QrZgq%oc66|wGQMZcKhcrz)6C_`|a z4_!H@T`}^!ino<^lWch75q7G@1DCy}FIVkvE8Uakj6{B0#46~V4P;Deni2wjp?cEW zS6Vg)7Kv)4k5nJOj&y8=hMlQe`X#x=9ivXAX?+zjCdxZ~U{%PA)I@9>LtEE&tlHKn zjrlk?S-;+^>!XN@rasUXX`F6|v##4)BkB!9UTo^4IN@=o83aj~Zw~EXXhjzVvn>%E zi@uy}I-3}LluS!#74Xz8BdtXfT1K64iNum^6YNK*=%6#a6z}kp9PrN$wE9+Su*p$d z@|j=`vAN{T=|f>SLBp;-O(IvEtBS4&SJqe8$j)}DWl20s?K_rXSScsQ0-eB`C>$vY zf}t@I9h{%oyWayjuqx6t(_gm{Y0(?0c8A=;j<8~+-WenKsHK18NYUlrJwj z&RHWxmnV%DA@^|6W%s0(Mg=h^`Ar14s8TI5QuQ@$dZflTTb!6J%YDi1y{Bxlz7u>z z%H)x$g^}RKW})1}ab^1|=7bZUBg0pgsrOuy^X_fa)8cJrtNqD?%C+%2+{G3SqfpS> QlunlP@K}y5{@;lI02z1h=l}o! literal 270 zcmZXP!3x4K5Jd0!iv0nFUJZIsJQTbMy@oZ}mSEYGBo+JjrmcxWFUvAJ%$rq~Bl#9J zDY$fJ%ZB^}l~D8^oR2|?pSo_AyO6B4skwE~xE`bJ>E<-tBRoEfB0hIEfU znH{Ip3gR@-7r8_pp+SG;*SJ(|-Xe#Rq`l BT?haG diff --git a/ghc/compiler/codeGen/CgBindery.lhs-boot b/ghc/compiler/codeGen/CgBindery.lhs-boot new file mode 100644 index 0000000..e504a6a --- /dev/null +++ b/ghc/compiler/codeGen/CgBindery.lhs-boot @@ -0,0 +1,11 @@ +\begin{code} +module CgBindery where +import VarEnv( IdEnv ) + +data CgIdInfo +data VolatileLoc +data StableLoc +type CgBindings = IdEnv CgIdInfo + +nukeVolatileBinds :: CgBindings -> CgBindings +\end{code} \ No newline at end of file diff --git a/ghc/compiler/codeGen/CgExpr.hi-boot b/ghc/compiler/codeGen/CgExpr.hi-boot index a091afa31fe7c2ff1c84502255e5724732cbda7e..6794d184cd290eac5b7d60ffe9b14d6f8244c8c6 100644 GIT binary patch literal 1948 zcmZ9M>2@1M5QQac8EqywVN2L|vp6^ehs0rv$C4u=S;CTImhhuBYAbU*nh`y%VCl_x z3C`hl_(k2@BZKid`ubLNS9f)FjdS_G|IFnI)qF0Oy8~_&zem1Len5UmZjv97ACsSupORbTP4Y8xo4iGSPTnTJAa}?+P9_!0OC*aWtKUEsd_*8YI<PKQpK|PV5^U;S|1&7}oOf`zD++?HUv|)wr;CG&WgIr9t;d z^I`)NbP}9X9@vR{!-gyC-u(2G^{EUN=`cxL2MpP5vc5E2xCbqw?${oq+f`(Wqs3bj zc@i2e)fcONESE~gI(y!-n7_5U2!@h3Km_G{Hj8)}Saa4n3o1NTc(t+&&G=cSTxiu- zBNc7ky16ax%1Ama)9cc0XF7`R-OU`=BzJ3)Xc>wK=Eg|NO3c*@ck?{ZGaIsH|Ml{l zS%!n5tgWM`m*E3r6cXL|kGTxxyF|`cE;-vhaozZzYZ*#IYZEKh_qv-s(6KgQkYW;_ zS->aW$QoOcUWTh~Z(KP07Imo}Je1k&d}rW_GE?JBD@qiuTA}4WCbukWQfHhb20c^s Q<+Wt=q&u>IJ>`JvAAZ_V{{R30 literal 109 zcma#g%qvMPN=r;mjaP6^cdaNWQZVF-Ppv4(FDfaH=Yk3)Lu9PE;!{$Sa}tXZOEUBG rfYOEvP?>nEc!l7S^x(=oJs<@(M%NB#pl^O&Vv3$~eoCr>wKW$2H&P_) diff --git a/ghc/compiler/codeGen/CgExpr.lhs-boot b/ghc/compiler/codeGen/CgExpr.lhs-boot new file mode 100644 index 0000000..29cdc3a --- /dev/null +++ b/ghc/compiler/codeGen/CgExpr.lhs-boot @@ -0,0 +1,7 @@ +\begin{code} +module CgExpr where +import StgSyn( StgExpr ) +import CgMonad( Code ) + +cgExpr :: StgExpr -> Code +\end{code} diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs-boot b/ghc/compiler/codeGen/ClosureInfo.lhs-boot new file mode 100644 index 0000000..b069905 --- /dev/null +++ b/ghc/compiler/codeGen/ClosureInfo.lhs-boot @@ -0,0 +1,6 @@ +\begin{code} +module ClosureInfo where + +data LambdaFormInfo +data ClosureInfo +\end{code} \ No newline at end of file diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 406c7a3..b31eeb1 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -13,12 +13,15 @@ module CompManager ( cmInit, -- :: GhciMode -> IO CmState cmDepAnal, -- :: CmState -> [FilePath] -> IO ModuleGraph + cmTopSort, -- :: Bool -> ModuleGraph -> [SCC ModSummary] + cyclicModuleErr, -- :: [ModSummary] -> String -- Used by DriverMkDepend cmLoadModules, -- :: CmState -> ModuleGraph -- -> IO (CmState, Bool, [String]) cmUnload, -- :: CmState -> IO CmState + #ifdef GHCI cmModuleIsInterpreted, -- :: CmState -> String -> IO Bool @@ -55,20 +58,23 @@ import Packages ( isHomePackage ) import DriverPipeline ( CompResult(..), preprocess, compile, link ) import HscMain ( newHscEnv ) import DriverState ( v_Output_file, v_NoHsMain, v_MainModIs ) -import DriverPhases -import Finder -import HscTypes -import PrelNames ( gHC_PRIM ) -import Module ( Module, mkModule, delModuleEnvList, mkModuleEnv, - lookupModuleEnv, moduleEnvElts, extendModuleEnv, - moduleUserString, +import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, isHaskellSrcFilename ) +import Finder ( findModule, findLinkable, addHomeModuleToFinder, flushFinderCache, + mkHomeModLocation, FindResult(..), cantFindError ) +import HscTypes ( ModSummary(..), HomeModInfo(..), ModIface(..), msHsFilePath, + HscEnv(..), GhciMode(..), + InteractiveContext(..), emptyInteractiveContext, + HomePackageTable, emptyHomePackageTable, IsBootInterface, + Linkable(..), isObjectLinkable ) +import Module ( Module, mkModule, delModuleEnv, delModuleEnvList, mkModuleEnv, + lookupModuleEnv, moduleEnvElts, extendModuleEnv, filterModuleEnv, + moduleUserString, addBootSuffixLocn, ModLocation(..) ) -import GetImports -import LoadIface ( noIfaceErr ) +import GetImports ( getImports ) import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs ) import ErrUtils ( showPass ) import SysTools ( cleanTempFilesExcept ) -import BasicTypes ( SuccessFlag(..), succeeded, failed ) +import BasicTypes ( SuccessFlag(..), succeeded ) import StringBuffer ( hGetStringBuffer ) import Util import Outputable @@ -81,20 +87,18 @@ import DATA_IOREF ( readIORef ) #ifdef GHCI import HscMain ( hscGetInfo, GetInfoResult, hscStmt, hscTcExpr, hscKcType ) +import HscTypes ( TyThing(..), icPrintUnqual, showModMsg ) import TcRnDriver ( mkExportEnv, getModuleContents ) import IfaceSyn ( IfaceDecl ) import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv ) -import Module ( showModMsg ) import Name ( Name ) import NameEnv import Id ( idType ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) -import BasicTypes ( Fixity ) import Linker ( HValue, unload, extendLinkEnv ) import GHC.Exts ( unsafeCoerce# ) import Foreign -import SrcLoc ( SrcLoc ) import Control.Exception as Exception ( Exception, try ) import CmdLineOpts ( DynFlag(..), dopt_unset ) #endif @@ -107,7 +111,6 @@ import IO import Monad import List ( nub ) import Maybe -import Time ( ClockTime ) \end{code} @@ -134,47 +137,21 @@ emptyMG :: ModuleGraph emptyMG = [] -------------------- -data ModSummary - = ModSummary { - ms_mod :: Module, -- Name of the module - ms_boot :: IsBootInterface, -- Whether this is an hi-boot file - ms_location :: ModLocation, -- Location - ms_srcimps :: [Module], -- Source imports - ms_imps :: [Module], -- Non-source imports - ms_hs_date :: ClockTime -- Timestamp of summarised file - } - --- The ModLocation contains both the original source filename and the --- filename of the cleaned-up source file after all preprocessing has been --- done. The point is that the summariser will have to cpp/unlit/whatever --- all files anyway, and there's no point in doing this twice -- just --- park the result in a temp file, put the name of it in the location, --- and let @compile@ read from that file on the way back up. - -instance Outputable ModSummary where - ppr ms - = sep [text "ModSummary {", - nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), - text "ms_mod =" <+> ppr (ms_mod ms) <> comma, - text "ms_imps =" <+> ppr (ms_imps ms), - text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), - char '}' - ] - +ms_allimps :: ModSummary -> [Module] ms_allimps ms = ms_srcimps ms ++ ms_imps ms -------------------- -type NodeKey = (Module, IsBootInterface) -- The nodes of the graph are -type NodeMap a = FiniteMap NodeKey a -- keyed by (mod,boot) pairs +type NodeKey = (Module, HscSource) -- The nodes of the graph are +type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs msKey :: ModSummary -> NodeKey -msKey (ModSummary { ms_mod = mod, ms_boot = boot }) = (mod,boot) +msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (mod,boot) emptyNodeMap :: NodeMap a emptyNodeMap = emptyFM -mkNodeMap :: [(NodeKey,a)] -> NodeMap a -mkNodeMap = listToFM +mkNodeMap :: [ModSummary] -> NodeMap ModSummary +mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries] nodeMapElts :: NodeMap a -> [a] nodeMapElts = eltsFM @@ -234,6 +211,9 @@ findModuleLinkable_maybe lis mod [] -> Nothing [li] -> Just li many -> pprPanic "findModuleLinkable" (ppr mod) + +delModuleLinkable :: [Linkable] -> Module -> [Linkable] +delModuleLinkable ls mod = [ l | l@(LM _ nm _) <- ls, nm /= mod ] \end{code} @@ -320,15 +300,13 @@ cmBrowseModule cmstate str exports_only ----------------------------------------------------------------------------- cmShowModule :: CmState -> ModSummary -> String cmShowModule cmstate mod_summary - = case lookupModuleEnv hpt mod of + = case lookupModuleEnv hpt (ms_mod mod_summary) of Nothing -> panic "missing linkable" - Just mod_info -> showModMsg obj_linkable mod locn + Just mod_info -> showModMsg obj_linkable mod_summary where obj_linkable = isObjectLinkable (hm_linkable mod_info) where hpt = hsc_HPT (cm_hsc cmstate) - mod = ms_mod mod_summary - locn = ms_location mod_summary ----------------------------------------------------------------------------- -- cmRunStmt: Run a statement/expr. @@ -500,14 +478,15 @@ cmUnload state@CmState{ cm_hsc = hsc_env } -- Start with a fresh CmState, but keep the PersistentCompilerState return (discardCMInfo state) -cm_unload hsc_env linkables +cm_unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' = case hsc_mode hsc_env of Batch -> return () #ifdef GHCI - Interactive -> Linker.unload (hsc_dflags hsc_env) linkables + Interactive -> Linker.unload (hsc_dflags hsc_env) stable_linkables #else - Interactive -> panic "unload: no interpreter" + Interactive -> panic "cm_unload: no interpreter" #endif + other -> panic "cm_unload: strange mode" ----------------------------------------------------------------------------- @@ -567,7 +546,7 @@ cmLoadModules cmstate1 mg2unsorted -- mg2 should be cycle free; but it includes hi-boot ModSummary nodes let mg2 :: [SCC ModSummary] - mg2 = topological_sort False mg2unsorted + mg2 = cmTopSort False mg2unsorted -- mg2_with_srcimps drops the hi-boot nodes, returning a -- graph with cycles. Among other things, it is used for @@ -575,7 +554,7 @@ cmLoadModules cmstate1 mg2unsorted -- upsweep, and for removing from hpt all the modules -- not in strict downwards closure, during calls to compile. let mg2_with_srcimps :: [SCC ModSummary] - mg2_with_srcimps = topological_sort True mg2unsorted + mg2_with_srcimps = cmTopSort True mg2unsorted -- Sort out which linkables we wish to keep in the unlinked image. -- See getValidLinkables below for details. @@ -585,8 +564,10 @@ cmLoadModules cmstate1 mg2unsorted -- putStrLn (showSDoc (vcat [ppr valid_old_linkables, ppr new_linkables])) - let hpt2 = delModuleEnvList hpt1 (map linkableModule new_linkables) - hsc_env2 = hsc_env { hsc_HPT = hpt2 } + -- The new_linkables are .o files we found on the disk, presumably + -- as a result of a GHC run "on the side". So we'd better forget + -- everything we know abouut those modules! + let old_hpt = delModuleEnvList hpt1 (map linkableModule new_linkables) -- When (verb >= 2) $ -- putStrLn (showSDoc (text "Valid linkables:" @@ -610,26 +591,28 @@ cmLoadModules cmstate1 mg2unsorted stable_linkables = filter (\m -> linkableModule m `elem` stable_mods) valid_old_linkables + stable_hpt = filterModuleEnv is_stable_hm hpt1 + is_stable_hm hm_info = mi_module (hm_iface hm_info) `elem` stable_mods + + upsweep_these + = filter (\scc -> any (`notElem` stable_mods) + (map ms_mod (flattenSCC scc))) + mg2 + when (verb >= 2) $ hPutStrLn stderr (showSDoc (text "Stable modules:" <+> sep (map (text.moduleUserString) stable_mods))) - -- Unload any modules which are going to be re-linked this - -- time around. - cm_unload hsc_env2 stable_linkables + -- Unload any modules which are going to be re-linked this time around. + cm_unload hsc_env stable_linkables - -- we can now glom together our linkable sets + -- We can now glom together our linkable sets let valid_linkables = valid_old_linkables ++ new_linkables -- We could at this point detect cycles which aren't broken by -- a source-import, and complain immediately, but it seems better -- to let upsweep_mods do this, so at least some useful work gets -- done before the upsweep is abandoned. - let upsweep_these - = filter (\scc -> any (`notElem` stable_mods) - (map ms_mod (flattenSCC scc))) - mg2 - --hPutStrLn stderr "after tsort:\n" --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) @@ -646,7 +629,8 @@ cmLoadModules cmstate1 mg2unsorted (ppFilesFromSummaries (flattenSCCs mg2)) (upsweep_ok, hsc_env3, modsUpswept) - <- upsweep_mods hsc_env2 valid_linkables + <- upsweep_mods (hsc_env { hsc_HPT = stable_hpt }) + (old_hpt, valid_linkables) cleanup upsweep_these -- At this point, modsUpswept and newLis should have the same @@ -743,8 +727,7 @@ cmLoadFinish ok Succeeded cmstate -- used to fish out the preprocess output files for the purposes of -- cleaning up. The preprocessed file *might* be the same as the -- source file, but that doesn't do any harm. -ppFilesFromSummaries summaries - = [ fn | Just fn <- map (ml_hspp_file.ms_location) summaries ] +ppFilesFromSummaries summaries = [ fn | Just fn <- map ms_hspp_file summaries ] ----------------------------------------------------------------------------- -- getValidLinkables @@ -774,7 +757,8 @@ getValidLinkables -> [Module] -- all home modules -> [SCC ModSummary] -- all modules in the program, dependency order -> IO ( [Linkable], -- still-valid linkables - [Linkable] -- new linkables we just found + [Linkable] -- new linkables we just found on the disk + -- presumably generated by separate run of ghc ) getValidLinkables mode old_linkables all_home_mods module_graph @@ -960,11 +944,10 @@ findPartiallyCompletedCycles modsDone theGraph -- Compile multiple modules, stopping as soon as an error appears. -- There better had not be any cyclic groups here -- we check for them. -upsweep_mods :: HscEnv -- Includes up-to-date HPT - -> [Linkable] -- Valid linkables - -> IO () -- how to clean up unwanted tmp files - -> [SCC ModSummary] -- mods to do (the worklist) - -- ...... RETURNING ...... +upsweep_mods :: HscEnv -- Includes initially-empty HPT + -> (HomePackageTable, [Linkable]) -- HPT and valid linkables from last time round + -> IO () -- How to clean up unwanted tmp files + -> [SCC ModSummary] -- Mods to do (the worklist) -> IO (SuccessFlag, HscEnv, -- With an updated HPT [ModSummary]) -- Mods which succeeded @@ -975,51 +958,70 @@ upsweep_mods hsc_env oldUI cleanup upsweep_mods hsc_env oldUI cleanup (CyclicSCC ms:_) - = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++ - unwords (map (moduleUserString.ms_mod) ms)) + = do hPutStrLn stderr (showSDoc (cyclicModuleErr ms)) return (Failed, hsc_env, []) -upsweep_mods hsc_env oldUI cleanup +upsweep_mods hsc_env oldUI@(old_hpt, old_linkables) cleanup (AcyclicSCC mod:mods) = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ -- show (map (moduleUserString.moduleName.mi_module.hm_iface) -- (moduleEnvElts (hsc_HPT hsc_env))) - (ok_flag, hsc_env1) <- upsweep_mod hsc_env oldUI mod + mb_mod_info <- upsweep_mod hsc_env oldUI mod cleanup -- Remove unwanted tmp files between compilations - if failed ok_flag then - return (Failed, hsc_env1, []) - else do - (restOK, hsc_env2, modOKs) <- upsweep_mods hsc_env1 oldUI cleanup mods - return (restOK, hsc_env2, mod:modOKs) + case mb_mod_info of + Nothing -> return (Failed, hsc_env, []) + Just mod_info -> do + { let this_mod = ms_mod mod + + -- Add new info to hsc_env + hpt1 = extendModuleEnv (hsc_HPT hsc_env) this_mod mod_info + hsc_env1 = hsc_env { hsc_HPT = hpt1 } + + -- Space-saving: delete the old HPT entry and linkable for mod + -- BUT if mod is a hs-boot node, don't delete it + -- For the linkable this is dead right: the linkable relates only + -- to the main Haskell source file. + -- For the interface, the HPT entry is probaby for the main Haskell + -- source file. Deleting it would force + oldUI1 | isHsBoot (ms_hsc_src mod) = oldUI + | otherwise + = (delModuleEnv old_hpt this_mod, + delModuleLinkable old_linkables this_mod) + + ; (restOK, hsc_env2, modOKs) <- upsweep_mods hsc_env1 oldUI1 cleanup mods + ; return (restOK, hsc_env2, mod:modOKs) } -- Compile a single module. Always produce a Linkable for it if -- successful. If no compilation happened, return the old Linkable. upsweep_mod :: HscEnv - -> UnlinkedImage + -> (HomePackageTable, UnlinkedImage) -> ModSummary - -> IO (SuccessFlag, - HscEnv) -- With updated HPT - -upsweep_mod hsc_env oldUI summary1 - | ms_boot summary1 -- The summary describes an hi-boot file, - = -- so there is nothing to do - return (Succeeded, hsc_env) + -> IO (Maybe HomeModInfo) -- Nothing => Failed - | otherwise -- The summary describes a regular source file, so compile it +upsweep_mod hsc_env (old_hpt, old_linkables) summary = do - let this_mod = ms_mod summary1 - location = ms_location summary1 - hpt1 = hsc_HPT hsc_env - - let mb_old_iface = case lookupModuleEnv hpt1 this_mod of - Just mod_info -> Just (hm_iface mod_info) - Nothing -> Nothing - - let maybe_old_linkable = findModuleLinkable_maybe oldUI this_mod + let this_mod = ms_mod summary + + -- The old interface is ok if it's in the old HPT + -- a) we're compiling a source file, and the old HPT entry is for a source file + -- b) we're compiling a hs-boot file + -- Case (b) allows an hs-boot file to get the interface of its real source file + -- on the second iteration of the compilation manager, but that does no harm. + -- Otherwise the hs-boot file will always be recompiled + mb_old_iface + = case lookupModuleEnv old_hpt this_mod of + Nothing -> Nothing + Just hm_info | isHsBoot (ms_hsc_src summary) -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info + + maybe_old_linkable = findModuleLinkable_maybe old_linkables this_mod source_unchanged = isJust maybe_old_linkable old_linkable = expectJust "upsweep_mod:old_linkable" maybe_old_linkable @@ -1028,9 +1030,7 @@ upsweep_mod hsc_env oldUI summary1 | Just l <- maybe_old_linkable, isObjectLinkable l = True | otherwise = False - compresult <- compile hsc_env this_mod location - (ms_hs_date summary1) - source_unchanged have_object mb_old_iface + compresult <- compile hsc_env summary source_unchanged have_object mb_old_iface case compresult of @@ -1044,12 +1044,10 @@ upsweep_mod hsc_env oldUI summary1 hm_globals = new_globals, hm_details = new_details, hm_linkable = new_linkable } - hpt2 = extendModuleEnv hpt1 this_mod new_info - - return (Succeeded, hsc_env { hsc_HPT = hpt2 }) + return (Just new_info) -- Compilation failed. Compile may still have updated the PCS, tho. - CompErrs -> return (Failed, hsc_env) + CompErrs -> return Nothing -- Filter modules in the HPT retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable @@ -1060,9 +1058,9 @@ retainInTopLevelEnvs keep_these hpt , isJust mb_mod_info ] ----------------------------------------------------------------------------- -topological_sort :: Bool -- Drop hi-boot nodes? (see below) - -> [ModSummary] - -> [SCC ModSummary] +cmTopSort :: Bool -- Drop hi-boot nodes? (see below) + -> [ModSummary] + -> [SCC ModSummary] -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes -- -- Drop hi-boot nodes (first boolean arg)? @@ -1074,28 +1072,30 @@ topological_sort :: Bool -- Drop hi-boot nodes? (see below) -- the a source-import of Foo is an import of Foo -- The resulting graph has no hi-boot nodes, but can by cyclic -topological_sort drop_hi_boot_nodes summaries +cmTopSort drop_hs_boot_nodes summaries = stronglyConnComp nodes where - keep_hi_boot_nodes = not drop_hi_boot_nodes + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = HsSrcFile + | otherwise = HsBootFile -- We use integers as the keys for the SCC algorithm nodes :: [(ModSummary, Int, [Int])] - nodes = [(s, fromJust (lookup_key (ms_boot s) (ms_mod s)), - out_edge_keys keep_hi_boot_nodes (ms_srcimps s) ++ - out_edge_keys False (ms_imps s) ) + nodes = [(s, fromJust (lookup_key (ms_hsc_src s) (ms_mod s)), + out_edge_keys hs_boot_key (ms_srcimps s) ++ + out_edge_keys HsSrcFile (ms_imps s) ) | s <- summaries - , not (ms_boot s) || keep_hi_boot_nodes ] + , not (ms_hsc_src s == HsBootFile && drop_hs_boot_nodes) ] -- Drop the hi-boot ones if told to do so key_map :: NodeMap Int - key_map = listToFM ([(ms_mod s, ms_boot s) | s <- summaries] + key_map = listToFM ([(ms_mod s, ms_hsc_src s) | s <- summaries] `zip` [1..]) - lookup_key :: IsBootInterface -> Module -> Maybe Int - lookup_key hi_boot mod = lookupFM key_map (mod, hi_boot) + lookup_key :: HscSource -> Module -> Maybe Int + lookup_key hs_src mod = lookupFM key_map (mod, hs_src) - out_edge_keys :: IsBootInterface -> [Module] -> [Int] + out_edge_keys :: HscSource -> [Module] -> [Int] out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms -- If we want keep_hi_boot_nodes, then we do lookup_key with -- the IsBootInterface parameter True; else False @@ -1116,10 +1116,11 @@ downsweep :: DynFlags -> [FilePath] -> [ModSummary] -> IO [ModSummary] downsweep dflags roots old_summaries = do rootSummaries <- mapM getRootSummary roots checkDuplicates rootSummaries - loop rootSummaries emptyNodeMap + loop (concatMap msImports rootSummaries) + (mkNodeMap rootSummaries) where old_summary_map :: NodeMap ModSummary - old_summary_map = mkNodeMap [ (msKey s, s) | s <- old_summaries] + old_summary_map = mkNodeMap old_summaries getRootSummary :: FilePath -> IO ModSummary getRootSummary file @@ -1133,7 +1134,7 @@ downsweep dflags roots old_summaries exists <- doesFileExist lhs_file if exists then summariseFile dflags lhs_file else do let mod_name = mkModule file - maybe_summary <- getSummary file False {- Not hi-boot -} mod_name + maybe_summary <- summarise dflags emptyNodeMap Nothing False mod_name case maybe_summary of Nothing -> packageModErr mod_name Just s -> return s @@ -1157,46 +1158,30 @@ downsweep dflags roots old_summaries [ fromJust (ml_hs_file (ms_location summ')) | summ' <- summaries, ms_mod summ' == modl ] - loop :: [ModSummary] -- Work list: process the imports of these modules + loop :: [(FilePath,Module,IsBootInterface)] -- Work list: process these modules -> NodeMap ModSummary -- Visited set -> IO [ModSummary] -- The result includes the worklist, except -- for those mentioned in the visited set loop [] done = return (nodeMapElts done) - loop (s:ss) done | key `elemFM` done = loop ss done - | otherwise = do { new_ss <- children s - ; loop (new_ss ++ ss) (addToFM done key s) } - where - key = (ms_mod s, ms_boot s) - - children :: ModSummary -> IO [ModSummary] - children s = do { mb_kids1 <- mapM (getSummary cur_path True) (ms_srcimps s) - ; mb_kids2 <- mapM (getSummary cur_path False) (ms_imps s) - ; return (catMaybes mb_kids1 ++ catMaybes mb_kids2) } - -- The Nothings are the ones from other packages: ignore + loop ((cur_path, wanted_mod, is_boot) : ss) done + | key `elemFM` done = loop ss done + | otherwise = do { mb_s <- summarise dflags old_summary_map + (Just cur_path) is_boot wanted_mod + ; case mb_s of + Nothing -> loop ss done + Just s -> loop (msImports s ++ ss) + (addToFM done key s) } where - cur_path = fromJust (ml_hs_file (ms_location s)) + key = (wanted_mod, if is_boot then HsBootFile else HsSrcFile) - getSummary :: FilePath -- Import directive is in here [only used for err msg] - -> IsBootInterface -- Look for an hi-boot file? - -> Module -- Look for this module - -> IO (Maybe ModSummary) - getSummary cur_mod is_boot wanted_mod - = do found <- findModule dflags wanted_mod True {-explicit-} - case found of - Found location pkg - | isHomePackage pkg -- Drop an external-package modules - -> do { let old_summary = lookupFM old_summary_map (wanted_mod, is_boot) - ; summarise dflags wanted_mod is_boot location old_summary } - | otherwise - -> return Nothing -- External package module +msImports :: ModSummary -> [(FilePath, -- Importing module + Module, -- Imported module + IsBootInterface)] -- {-# SOURCE #-} import or not +msImports s = [(f, m,True) | m <- ms_srcimps s] + ++ [(f, m,False) | m <- ms_imps s] + where + f = msHsFilePath s -- Keep the importing module for error reporting - err -> throwDyn (noModError dflags cur_mod wanted_mod err) - - --- ToDo: we don't have a proper line number for this error -noModError dflags loc mod_nm err - = ProgramError (showSDoc (hang (text loc <> colon) 4 $ - noIfaceErr dflags mod_nm err)) ----------------------------------------------------------------------------- -- Summarising modules @@ -1212,78 +1197,138 @@ noModError dflags loc mod_nm err -- resides. summariseFile :: DynFlags -> FilePath -> IO ModSummary +-- Used for Haskell source only, I think +-- We know the file name, and we know it exists, +-- but we don't necessarily know the module name (might differ) summariseFile dflags file - = do hspp_fn <- preprocess dflags file + = do (dflags', hspp_fn) <- preprocess dflags file + -- The dflags' contains the OPTIONS pragmas -- Read the file into a buffer. We're going to cache -- this buffer in the ModLocation (ml_hspp_buf) so that it -- doesn't have to be slurped again when hscMain parses the -- file later. buf <- hGetStringBuffer hspp_fn - (srcimps,imps,mod) <- getImports dflags buf hspp_fn - - let -- GHC.Prim doesn't exist physically, so don't go looking for it. - the_imps = filter (/= gHC_PRIM) imps + (srcimps,the_imps,mod) <- getImports dflags' buf hspp_fn + -- Make a ModLocation for this file location <- mkHomeModLocation mod file + -- Tell the Finder cache where it is, so that subsequent calls + -- to findModule will find it, even if it's not on any search path + addHomeModuleToFinder mod location + src_timestamp <- case ml_hs_file location of - Nothing -> noHsFileErr mod + Nothing -> noHsFileErr Nothing mod Just src_fn -> getModificationTime src_fn - return (ModSummary { ms_mod = mod, ms_boot = False, - ms_location = location{ml_hspp_file=Just hspp_fn}, + return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, + ms_location = location, + ms_hspp_file = Just hspp_fn, + ms_hspp_buf = Just buf, ms_srcimps = srcimps, ms_imps = the_imps, ms_hs_date = src_timestamp }) -- Summarise a module, and pick up source and timestamp. summarise :: DynFlags - -> Module -- Guaranteed a home-package module - -> IsBootInterface - -> ModLocation -> Maybe ModSummary - -> IO (Maybe ModSummary) -summarise dflags mod is_boot location old_summary - = do { -- Find the source file to summarise - src_fn <- if is_boot then - hiBootFilePath location - else - case ml_hs_file location of - Nothing -> noHsFileErr mod - Just src_fn -> return src_fn - - -- Find its timestamp - ; src_timestamp <- getModificationTime src_fn - - -- return the cached summary if the source didn't change - ; case old_summary of { - Just s | ms_hs_date s == src_timestamp -> return (Just s); - _ -> do - - -- For now, we never pre-process hi-boot files - { hspp_fn <- if is_boot then return src_fn - else preprocess dflags src_fn + -> NodeMap ModSummary -- Map of old summaries + -> Maybe FilePath -- Importing module (for error messages) + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Module -- Imported module to be summarised + -> IO (Maybe ModSummary) -- Its new summary + +summarise dflags old_summary_map cur_mod is_boot wanted_mod + = do { found <- findModule dflags wanted_mod True {-explicit-} + ; case found of + Found location pkg + | isHomePackage pkg + -> do { summary <- do_summary location + ; return (Just summary) } + | otherwise + -> return Nothing -- Drop an external-package modules + + err -> noModError dflags cur_mod wanted_mod err + } + where + hsc_src = if is_boot then HsBootFile else HsSrcFile + + do_summary location + = do { -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let location' | is_boot = addBootSuffixLocn location + | otherwise = location + + -- Find the source file to summarise + ; src_fn <- case ml_hs_file location' of + Nothing -> noHsFileErr cur_mod wanted_mod + Just src_fn -> return src_fn + + -- In the case of hs-boot files, check that it exists + -- The Finder was dealing only with the main source file + ; if is_boot then do + { exists <- doesFileExist src_fn + ; if exists then return () + else noHsBootFileErr cur_mod src_fn } + else return () + + -- Find its timestamp + ; src_timestamp <- getModificationTime src_fn + + -- return the cached summary if the source didn't change + ; case lookupFM old_summary_map (wanted_mod, hsc_src) of { + Just s | ms_hs_date s == src_timestamp -> return s; + _ -> do + + -- Preprocess the source file + { (dflags', hspp_fn) <- preprocess dflags src_fn + -- The dflags' contains the OPTIONS pragmas ; buf <- hGetStringBuffer hspp_fn - ; (srcimps,imps,mod_name) <- getImports dflags buf hspp_fn - ; let - -- GHC.Prim doesn't exist physically, so don't go looking for it. - the_imps = filter (/= gHC_PRIM) imps + ; (srcimps, the_imps, mod_name) <- getImports dflags' buf hspp_fn - ; when (mod_name /= mod) $ + ; when (mod_name /= wanted_mod) $ throwDyn (ProgramError (showSDoc (text src_fn <> text ": file name does not match module name" - <+> quotes (ppr mod)))) - - ; let new_loc = location{ ml_hspp_file = Just hspp_fn, - ml_hspp_buf = Just buf } - ; return (Just (ModSummary mod is_boot new_loc - srcimps the_imps src_timestamp)) + <+> quotes (ppr mod_name)))) + + ; return (ModSummary { ms_mod = wanted_mod, + ms_hsc_src = hsc_src, + ms_location = location', + ms_hspp_file = Just hspp_fn, + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, + ms_imps = the_imps, + ms_hs_date = src_timestamp }) }}} -noHsFileErr mod - = throwDyn (CmdLineError (showSDoc (text "no source file for module" <+> quotes (ppr mod)))) + +----------------------------------------------------------------------------- +-- Error messages +----------------------------------------------------------------------------- + +noModError :: DynFlags -> Maybe FilePath -> Module -> FindResult -> IO ab +-- ToDo: we don't have a proper line number for this error +noModError dflags cur_mod wanted_mod err + = throwDyn $ ProgramError $ showSDoc $ + vcat [cantFindError dflags wanted_mod err, + nest 2 (parens (pp_where cur_mod))] + +noHsFileErr :: Maybe FilePath -> Module -> IO a +-- Complain about not being able to find an imported module +noHsFileErr cur_mod mod + = throwDyn $ CmdLineError $ showSDoc $ + vcat [text "No source file for module" <+> quotes (ppr mod), + nest 2 (parens (pp_where cur_mod))] + +noHsBootFileErr cur_mod path + = throwDyn $ CmdLineError $ showSDoc $ + vcat [text "Can't find" <+> text path, + nest 2 (parens (pp_where cur_mod))] + +pp_where Nothing = text "one of the roots of the dependency analysis" +pp_where (Just p) = text "imported from" <+> text p packageModErr mod = throwDyn (CmdLineError (showSDoc (text "module" <+> @@ -1295,6 +1340,17 @@ multiRootsErr mod files text "module" <+> quotes (ppr mod) <+> text "is defined in multiple files:" <+> sep (map text files)))) -\end{code} +cyclicModuleErr :: [ModSummary] -> SDoc +cyclicModuleErr ms + = hang (ptext SLIT("Module imports form a cycle for modules:")) + 2 (vcat (map show_one ms)) + where + show_one ms = vcat [show_mod (ms_hsc_src ms) (ms_mod ms), + ptext SLIT("Imports:") <+> + (pp_imps HsBootFile (ms_srcimps ms) + $$ pp_imps HsSrcFile (ms_imps ms))] + show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) + pp_imps src mods = fsep (map (show_mod src) mods) +\end{code} diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index ea3d318..be26463 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -9,6 +9,7 @@ module Desugar ( deSugar, deSugarExpr ) where #include "HsVersions.h" import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt, opt_SccProfilingOn ) +import DriverPhases ( isHsBoot ) import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..), Dependencies(..), TypeEnv, IsBootInterface ) import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr, @@ -59,6 +60,7 @@ deSugar :: HscEnv -> TcGblEnv -> IO (Bag WarnMsg, Maybe ModGuts) deSugar hsc_env tcg_env@(TcGblEnv { tcg_mod = mod, + tcg_src = hsc_src, tcg_type_env = type_env, tcg_imports = imports, tcg_exports = exports, @@ -146,6 +148,7 @@ deSugar hsc_env mod_guts = ModGuts { mg_module = mod, + mg_boot = isHsBoot hsc_src, mg_exports = exports, mg_deps = deps, mg_usages = usages, diff --git a/ghc/compiler/deSugar/DsExpr.hi-boot b/ghc/compiler/deSugar/DsExpr.hi-boot index 2a163faf5f660d16987cfbf14d71c4c29217eab6..102a23be46addd904496d7ff27bba24eb3fdf6fb 100644 GIT binary patch literal 3307 zcmb7_X?xp55XYU`mV6|Xwp=Zga6^HXUX&In5X*6FYS$)qnwEPluN`4oQde>lhx@+I z7Cr{Ac)_RO1M!NP|4L3wU+|FU$xk!0v$M0av+LB{-+!f2*+1t}sni+9amFb~B+ws= z{GYzACFUM&0W)A0G(Z!~fqAe17Uy{GJmdxN7H}_kE4UBb4;}z-18)cK0Ph6v0uO?R zz`MbFz{B9Z;39Y*ct7|6_#pTY_%Qeg_$c@ocm#YLd;)wDJPIBIp8}7AC%}{7DeyG- zGU=NgF9~^)ipaZ@G4nY?jfgb3C z0eBTuUv(js6~Y>HCZiU{166A>$*)$BaeBCyY-SpD{jXe8KpV z@fG81#y5;_8Q(F!XZ*luGcGf(FkHrn{xg`nNzzQ zz+$5504I0+eojUZ`Si{JM6B`4j7vMwbg0X->Xlj5omF{nyn%Qhyt7!F5P+=-H>)8x^=Y z{{IPgeOEYL+MCk-?{Jh#D*FeMbNr3|jdHlW6)2L@B{85+p(H}b?o0w1l9nquUac=| z$*v>|HPKQu5&=p1(%5l(or%Q>+1O zbJrpV3ui4?gq%Uqa{X|uWXhGK;_;tV`KJYJdc zO?od^4Qr!-8j*an)v)ex@knTiSkN`3Fi8p|CTY{;X}@M`&1H1Wo*I|dsP*EL&7q6+ zn3i?OJnS5m)8tOoKA8)YFDFr#Tauf%P$tiqG3@D(cjb z{R_=;6pSO$MeKzZ^}ZO;J&gM_7aO?v*_QAen}m6~I-zV02kb_=(F&Aqc9SJKM>6JG zO1g3V@+@;A90tlN?S&PCMxqGMLQ6R#Y`(w}uPeER=4wyHd&nlUvhBvIM4j5ouKS#m z(T)cCQ08^pmB#%(YM*OQ!jA8wY0QqD6g%IsSG}Z>p(Nd5bkGqLG)r$2u1zL6WB%%; z&CVp`M9Hl{;<}?GwF_y*HL4Q5WASy#lG?`xNw`{RkcY{VKCS}9aS*sumoW}Go}IoV zxPJ`#=%Z#yPtC3SYPe39nZ~p0n{}s4Lf#Tx;T}D4>^Ld8F5Tx?UZA@@l&*X3Y-~6{ zJByU>ZaXAUYbbg)XwLqrd3np0LF8cnJ62R|+i7>mx5)3xwzH&^;OzJ9QnwxYCE$(h zoiWy$WIFUO)3!rzhE((vaYr1~qbt&r%CSQplFRaJzSrTRR4-@(-IRF3v literal 237 zcma)#y9xp^5JmfZ#r%K^+ZwQN6}HgI?T3&VF({KTNwNF)W*?m_SY5b}b1_I^eLBww zmwX+QLTix66t!eDn?-9v`NqW>B=#Stu7oJH)4~?x5n=FseoWE~Q)2&O|7Pmf@!?bt i?ok{yRiTT@b8*(?*4l+s9{_eq=OC1!qJHLo;LR6qVNl@! diff --git a/ghc/compiler/deSugar/DsExpr.lhs-boot b/ghc/compiler/deSugar/DsExpr.lhs-boot new file mode 100644 index 0000000..b3380a9 --- /dev/null +++ b/ghc/compiler/deSugar/DsExpr.lhs-boot @@ -0,0 +1,11 @@ +\begin{code} +module DsExpr where +import HsSyn ( HsExpr, LHsExpr, HsBindGroup ) +import Var ( Id ) +import DsMonad ( DsM ) +import CoreSyn ( CoreExpr ) + +dsExpr :: HsExpr Id -> DsM CoreExpr +dsLExpr :: LHsExpr Id -> DsM CoreExpr +dsLet :: [HsBindGroup Id] -> CoreExpr -> DsM CoreExpr +\end{code} diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index a188e0b..8fecc81 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -20,14 +20,19 @@ module DsMonad ( DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, - dsWarn, - DsWarning, - DsMatchContext(..) + -- Warnings + DsWarning, dsWarn, + + -- Data types + DsMatchContext(..), + EquationInfo(..), MatchResult(..), + CanItFail(..), orFail ) where #include "HsVersions.h" import TcRnMonad +import CoreSyn ( CoreExpr ) import HsSyn ( HsExpr, HsMatchContext, Pat ) import TcIface ( tcIfaceGlobal ) import RdrName ( GlobalRdrEnv ) @@ -56,6 +61,49 @@ import DATA_IOREF ( newIORef, readIORef ) infixr 9 `thenDs` \end{code} +%************************************************************************ +%* * + Data types for the desugarer +%* * +%************************************************************************ + +\begin{code} +data DsMatchContext + = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan + | NoMatchContext + deriving () + +data EquationInfo + = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn + eqn_rhs :: MatchResult } -- What to do after match + +-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult +-- \fail. wrap (case vs of { pats -> rhs fail }) +-- where vs are not in the domain of wrap + + +-- A MatchResult is an expression with a hole in it +data MatchResult + = MatchResult + CanItFail -- Tells whether the failure expression is used + (CoreExpr -> DsM CoreExpr) + -- Takes a expression to plug in at the + -- failure point(s). The expression should + -- be duplicatable! + +data CanItFail = CanFail | CantFail + +orFail CantFail CantFail = CantFail +orFail _ _ = CanFail +\end{code} + + +%************************************************************************ +%* * + Monad stuff +%* * +%************************************************************************ + Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around a @UniqueSupply@ and some annotations, which presumably include source-file location information: @@ -129,6 +177,12 @@ initDs hsc_env mod rdr_env type_env thing_inside mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc \end{code} +%************************************************************************ +%* * + Operations in the monad +%* * +%************************************************************************ + And all this mysterious stuff is so we can occasionally reach out and grab one or more names. @newLocalDs@ isn't exported---exported functions are defined with it. The difference in name-strings makes @@ -222,15 +276,3 @@ dsExtendMetaEnv menv thing_inside \end{code} -%************************************************************************ -%* * -\subsection{Type synonym @EquationInfo@ and access functions for its pieces} -%* * -%************************************************************************ - -\begin{code} -data DsMatchContext - = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan - | NoMatchContext - deriving () -\end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 10fd4ab..4105c88 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -187,14 +187,6 @@ The ``equation info'' used by @match@ is relatively complicated and worthy of a type synonym and a few handy functions. \begin{code} -data EquationInfo - = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn - eqn_rhs :: MatchResult } -- What to do after match - --- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult --- \fail. wrap (case vs of { pats -> rhs fail }) --- where vs are not in the domain of wrap - firstPat :: EquationInfo -> Pat Id firstPat eqn = head (eqn_pats eqn) @@ -208,23 +200,6 @@ shiftPats (ConPatOut _ _ _ _ (PrefixCon arg_pats) _ : pats) = map unLoc arg_pats shiftPats (pat_with_no_sub_pats : pats) = pats \end{code} - -\begin{code} --- A MatchResult is an expression with a hole in it -data MatchResult - = MatchResult - CanItFail -- Tells whether the failure expression is used - (CoreExpr -> DsM CoreExpr) - -- Takes a expression to plug in at the - -- failure point(s). The expression should - -- be duplicatable! - -data CanItFail = CanFail | CantFail - -orFail CantFail CantFail = CantFail -orFail _ _ = CanFail -\end{code} - Functions on MatchResults \begin{code} diff --git a/ghc/compiler/deSugar/Match.hi-boot b/ghc/compiler/deSugar/Match.hi-boot index f069e9137e0c6a81a82f13af64e40d68bab33d37..898c39f543ab65a1265f90ce2b34087656685ed4 100644 GIT binary patch literal 3769 zcma)-X?qh@6vtE3WU>_m+&~d`K>o-RSRfm%hh%ALb;BA22>-e8f1w_?Ynt<5R|GjL#WgFur7b z#rT@>4dYwJcZ}~DO~xh0WroA()Bp5eEUnT1RAMSgpK}ly?6?9A4lTxxLu1Deu<_g< zN77Ft>1UScU$3_x8rHkM$x$6Uv>4B5#>4ai95a^Fs zHk@VyqM5>sHP)jt=@D1hqU$rUhR!^uU`<`8u^v~3qtGGU)U&sRbduNCDZ}(C>rt8h zZ;aa(oiL1Jnuu}2ujA7(-qIWXcSsn4>TXZl)(!JnSSB(H{a-@3k=!<12Q^s-Jp_rz zWk_t@bF9aOprj^@gG@f^AM~H9iNIPRAvq^{^vTT$-?m!Af%Hks%-L?GD=bNJnq;Ad zS_=ANKvH%tw4F|CX!0$|&kX}rN!3^pJ_?uDI%Oi@`8lofE|}-XSJ>Xoh@=4r2FQE*|ev3f-a{a88V}&*hE8qO^4R%l`cO zfIA~o_AC7XDI}-Le%0pWk{WKh=!q7WrDA33sBPjp6iq$aGDIv*ol z6T>!2Fut>}Ef*0gkQT7G)H|mxZjn0x7s;J&ZT~Vj{ zJU&+sgFzUGHrAeLQ16Q#-NUF)Gm(LlpK1u#wn!+@)$wIxwa3FqPd5fiH@m?S)sc*u zhLTQ{zbwlf2rmO=k(XQ83&J`SH_iT9P9Lu0X{qBEr8S*d1iQ6f)GWmP?n zDcuZux+n$Rc5`93i`-|LL%-#DXd0ts#mUaLtVK6&WGHcWq+93+S~Nv(6Ryp4Tx0&~ zt&P^u=Rj##j>KhKNop6;@=KH@ddH&ck|MQ>1CnsHRHG3FOS)V+h~Z%1jE00Lax^=6 zQE>mH>7z@{lAfAb_SEV!U1sv9me;Cwn}n<>+QK<<{OB=KGHtrgkvv0pdsRBl*)x%0 z51lMfp0i<-K&_$Z*`PVQN9Or;OAZ1X=O0^6d^H zvU8KMQYX{CEv5~d-VCYeDdLXUtGx@-mCCk!cJf1Mp%3LlZy&cRc1JiH7UX!^a@ZoWtM+<%L|n>1y;=^`oEDJcOp**L|@gQr(^-^~eG&Tz&d& F`v)oaSHS=P literal 593 zcmcIh!K%VA5WM#*_6H1jweT(~)Po?e>O~}kbk$%?Y7)Wzy~(yk#lCm*l3jK-v$L~Y znSkyfByw1aAWtyPINodPg6COVxlo&iJ+{B6yvr5 z_=Ll5D;!%?dl>z|Zss>ZY0u`@8}%;C!4fj_OKU{MVuZelg#4nv=>U1&lXhypLESBv zsHfIp*%+2$oamDJ!l#TCo`g+pH1QswT`%ElS@`s4-P9;gD9>0$a}qMdHdK3c;RAnK eP^!*&GWer04tya>ckH$PD{{#8cdEZGlRW^gCd TcType.TcType - -> [DsUtils.EquationInfo] - -> DsMonad.DsM DsUtils.MatchResult + -> [DsMonad.EquationInfo] + -> DsMonad.DsM DsMonad.MatchResult matchWrapper :: HsExpr.HsMatchContext Name.Name @@ -23,5 +23,5 @@ matchSinglePat -> DsMonad.DsMatchContext -> HsPat.LPat Var.Id -> TcType.TcType - -> DsUtils.MatchResult - -> DsMonad.DsM DsUtils.MatchResult + -> DsMonad.MatchResult + -> DsMonad.DsM DsMonad.MatchResult diff --git a/ghc/compiler/deSugar/Match.lhs-boot b/ghc/compiler/deSugar/Match.lhs-boot new file mode 100644 index 0000000..424838e --- /dev/null +++ b/ghc/compiler/deSugar/Match.lhs-boot @@ -0,0 +1,35 @@ +\begin{code} +module Match where +import Var ( Id ) +import TcType ( TcType ) +import DsMonad ( DsM, DsMatchContext, EquationInfo, MatchResult ) +import CoreSyn ( CoreExpr ) +import HsSyn ( LPat, HsMatchContext, MatchGroup ) +import Name ( Name ) + +match :: [Id] + -> TcType + -> [EquationInfo] + -> DsM MatchResult + +matchWrapper + :: HsMatchContext Name + -> MatchGroup Id + -> DsM ([Id], CoreExpr) + +matchSimply + :: CoreExpr + -> HsMatchContext Name + -> LPat Id + -> CoreExpr + -> CoreExpr + -> DsM CoreExpr + +matchSinglePat + :: CoreExpr + -> DsMatchContext + -> LPat Id + -> TcType + -> MatchResult + -> DsM MatchResult +\end{code} diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index f4b7922..95d81bc 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -124,7 +124,6 @@ emptyPLS dflags = PersistentLinkerState { where init_pkgs | ExtPackage rts_id <- rtsPackageId (pkgState dflags) = [rts_id] | otherwise = [] - \end{code} \begin{code} diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index e3485b9..5a0da8f 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -242,16 +242,20 @@ sigName (L _ sig) = f sig f (FixSig (FixitySig n _)) = Just (unLoc n) f other = Nothing -isFixitySig :: Sig name -> Bool -isFixitySig (FixSig _) = True -isFixitySig _ = False +isFixityLSig :: LSig name -> Bool +isFixityLSig (L _ (FixSig _)) = True +isFixityLSig _ = False -isPragSig :: Sig name -> Bool +isVanillaLSig :: LSig name -> Bool +isVanillaLSig (L _(Sig name _)) = True +isVanillaLSig sig = False + +isPragLSig :: LSig name -> Bool -- Identifies pragmas -isPragSig (SpecSig _ _) = True -isPragSig (InlineSig _ _ _) = True -isPragSig (SpecInstSig _) = True -isPragSig other = False +isPragLSig (L _ (SpecSig _ _)) = True +isPragLSig (L _ (InlineSig _ _ _)) = True +isPragLSig (L _ (SpecInstSig _)) = True +isPragLSig other = False hsSigDoc (Sig _ _) = ptext SLIT("type signature") hsSigDoc (SpecSig _ _) = ptext SLIT("SPECIALISE pragma") diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot b/ghc/compiler/hsSyn/HsExpr.hi-boot index ecc9528d9ad9d049014865b0711c70a578043f38..0a8a789b25849ef470a8da6e7728466c7f562519 100644 GIT binary patch literal 1705 zcmbVK+fLg+5Z%Q|NJ2sj>4n}ev<1SYP^zkZB@lv?6sw`?^Tu&ug|RJrQxSfyf6$NV zW1l)_*0`lo5yFy>&z!mJ%y@c?GT;O&4r76_$XH^W zWGpjQB;u>gr#R&O-eBb>^BKlj#s=dpd;D$GxdXV%@*L@na8 z;3?o4;5nd9uk3;~z=U+@GtU%|hgio8))4aYLP&)z&V7|TxGgGy@CA#RWs9Lae2W${ zYl*F;%xbdLw57x{+7V*Kepc;gjWuxjo#Ui~s!MW$@HJ)wd@bhO$tXV3cu<@VijVkQ6bC4mKn!B zskQAyfAbUfNTojFtJeN(bO5WZQqwny4!HuX1Ij~Sv6H&W5GnQ4c)(Jr7Y#=Ns!r~E z-bZx;THPO+cx2Ro9d%cE$Li3}yDDb_mvmLAJ(P44-hHM8@kh(6Ju`AKqs|gN`&w6r5=y-Y7}@5Z%w_^3JK}$3{ot1+^E2 zYIvsm2c*ulqr}&TA(c4O=X}dxPudU419yeigx;jNi z*7y=7n0S)LRfdP3{#&j%`B@eghQ4!V3TZ literal 484 zcmbV|&1%Ci5QOi3ig|$wa;>Qkra!)fl=x`Mvaw|&nb$ptnxR13SEYt;0Rq_#uOW~oy zeNVK{bC0qta%$vdoN!AGAQ3)GU&#N%;;$C|A#g+{5d(fB3%BRqzD2_Pp@3lArL1_L I@9pOrt~5-dZ~y=R diff --git a/ghc/compiler/hsSyn/HsExpr.lhs-boot b/ghc/compiler/hsSyn/HsExpr.lhs-boot new file mode 100644 index 0000000..d42bad1 --- /dev/null +++ b/ghc/compiler/hsSyn/HsExpr.lhs-boot @@ -0,0 +1,26 @@ +\begin{code} +module HsExpr where + +import SrcLoc ( Located ) +import Outputable ( SDoc, OutputableBndr ) +import {-# SOURCE #-} HsPat ( LPat ) + +data HsExpr i +data HsSplice i +data MatchGroup a +data GRHSs a + +type LHsExpr a = Located (HsExpr a) + +pprExpr :: (OutputableBndr i) => + HsExpr i -> SDoc + +pprSplice :: (OutputableBndr i) => + HsSplice i -> SDoc + +pprPatBind :: (OutputableBndr b, OutputableBndr i) => + LPat b -> GRHSs i -> SDoc + +pprFunBind :: (OutputableBndr i) => + i -> MatchGroup i -> SDoc +\end{code} diff --git a/ghc/compiler/hsSyn/HsPat.lhs-boot b/ghc/compiler/hsSyn/HsPat.lhs-boot new file mode 100644 index 0000000..d5b685c --- /dev/null +++ b/ghc/compiler/hsSyn/HsPat.lhs-boot @@ -0,0 +1,7 @@ +\begin{code} +module HsPat where +import SrcLoc( Located ) + +data Pat i +type LPat i = Located (Pat i) +\end{code} diff --git a/ghc/compiler/iface/BinIface.hs b/ghc/compiler/iface/BinIface.hs index 8570f6b..b246be2 100644 --- a/ghc/compiler/iface/BinIface.hs +++ b/ghc/compiler/iface/BinIface.hs @@ -94,6 +94,7 @@ readBinIface hi_path = getBinFileWithDict hi_path instance Binary ModIface where put_ bh (ModIface { mi_module = mod, + mi_boot = is_boot, mi_mod_vers = mod_vers, mi_package = _, -- we ignore the package on output mi_orphan = orphan, @@ -111,6 +112,7 @@ instance Binary ModIface where build_tag <- readIORef v_Build_tag put bh build_tag put_ bh mod + put_ bh is_boot put_ bh mod_vers put_ bh orphan lazyPut bh deps @@ -145,7 +147,7 @@ instance Binary ModIface where ++ build_tag ++ ", found " ++ check_way)) mod_name <- get bh - + is_boot <- get bh mod_vers <- get bh orphan <- get bh deps <- lazyGet bh @@ -161,8 +163,8 @@ instance Binary ModIface where return (ModIface { mi_package = HomePackage, -- to be filled in properly later mi_module = mod_name, + mi_boot = is_boot, mi_mod_vers = mod_vers, - mi_boot = False, -- Binary interfaces are never .hi-boot files! mi_orphan = orphan, mi_deps = deps, mi_usages = usages, diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index 40cae9d..0ebfa0d 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -9,7 +9,7 @@ module IfaceType ( IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, - IfaceExtName(..), mkIfaceExtName, ifaceTyConName, + IfaceExtName(..), mkIfaceExtName, ifaceTyConName, ifPrintUnqual, -- Conversion from Type -> IfaceType toIfaceType, toIfacePred, toIfaceContext, @@ -65,6 +65,11 @@ data IfaceExtName mkIfaceExtName name = ExtPkg (nameModule name) (nameOccName name) -- Local helper for wired-in names + +ifPrintUnqual :: PrintUnqualified -> IfaceExtName -> Bool +ifPrintUnqual print_unqual (ExtPkg mod occ) = print_unqual mod occ +ifPrintUnqual print_unqual (HomePkg mod occ _) = print_unqual mod occ +ifPrintUnqual print_unqual other = True \end{code} diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index 142d86f..c33fae0 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -9,8 +9,7 @@ module LoadIface ( loadSrcInterface, loadOrphanModules, loadHiBootInterface, readIface, -- Used when reading the module's old interface predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags, - initExternalPackageState, - noIfaceErr, -- used by CompManager too + initExternalPackageState ) where #include "HsVersions.h" @@ -19,10 +18,7 @@ import {-# SOURCE #-} TcIface( tcIfaceDecl ) import Packages ( PackageState(..), PackageIdH(..), isHomePackage ) import DriverState ( v_GhcMode, isCompManagerMode ) -import DriverUtil ( replaceFilenameSuffix ) import CmdLineOpts ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) -import Parser ( parseIface ) - import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceInst(..), IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), @@ -55,28 +51,24 @@ import Name ( Name {-instance NamedThing-}, getOccName, import NameEnv import MkId ( seqId ) import Module ( Module, ModLocation(ml_hi_file), emptyModuleEnv, + addBootSuffix_maybe, extendModuleEnv, lookupModuleEnv, moduleUserString ) import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc ) import Class ( Class, className ) import TyCon ( tyConName ) -import SrcLoc ( mkSrcLoc, importedSrcLoc ) +import SrcLoc ( importedSrcLoc ) import Maybes ( mapCatMaybes, MaybeErr(..) ) -import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) -import ErrUtils ( Message, mkLocMessage ) -import Finder ( findModule, findPackageModule, FindResult(..), - hiBootFilePath ) -import Lexer +import ErrUtils ( Message ) +import Finder ( findModule, findPackageModule, FindResult(..), cantFindError ) import Outputable import BinIface ( readBinIface ) import Panic ( ghcError, tryMost, showException, GhcException(..) ) import List ( nub ) import DATA_IOREF ( readIORef ) - -import Directory \end{code} @@ -576,7 +568,7 @@ findAndReadIface explicit doc_str mod_name hi_boot_file Failed err -> do { traceIf (ptext SLIT("...not found")) ; dflags <- getDOpts - ; returnM (Failed (noIfaceErr dflags mod_name err)) } ; + ; returnM (Failed (cantFindError dflags mod_name err)) } ; Succeeded (file_path, pkg) -> do @@ -603,18 +595,17 @@ findHiFile dflags explicit mod_name hi_boot_file -- and start up GHCi - it won't complain that all the modules it tries -- to load are found in the home location. ghci_mode <- readIORef v_GhcMode ; - let { home_allowed = hi_boot_file || - not (isCompManagerMode ghci_mode) } ; + let { home_allowed = not (isCompManagerMode ghci_mode) } ; maybe_found <- if home_allowed - then findModule dflags mod_name explicit + then findModule dflags mod_name explicit else findPackageModule dflags mod_name explicit; case maybe_found of - Found loc pkg - | hi_boot_file -> do { hi_boot_path <- hiBootFilePath loc - ; return (Succeeded (hi_boot_path, pkg)) } - | otherwise -> return (Succeeded (ml_hi_file loc, pkg)) ; - err -> return (Failed err) + Found loc pkg -> return (Succeeded (path, pkg)) + where + path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) + + err -> return (Failed err) } \end{code} @@ -626,33 +617,20 @@ readIface :: Module -> String -> IsBootInterface -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed -readIface wanted_mod_name file_path is_hi_boot_file +readIface wanted_mod file_path is_hi_boot_file = do { dflags <- getDOpts - ; ioToIOEnv (read_iface dflags wanted_mod_name file_path is_hi_boot_file) } - -read_iface dflags wanted_mod file_path is_hi_boot_file - | is_hi_boot_file -- Read ascii - = do { res <- tryMost (hGetStringBuffer file_path) ; - case res of { - Left exn -> return (Failed (text (showException exn))) ; - Right buffer -> - case unP parseIface (mkPState buffer loc dflags) of - PFailed span err -> return (Failed (mkLocMessage span err)) - POk _ iface - | wanted_mod == actual_mod -> return (Succeeded iface) - | otherwise -> return (Failed err) - where - actual_mod = mi_module iface - err = hiModuleNameMismatchWarn wanted_mod actual_mod - }} - - | otherwise -- Read binary - = do { res <- tryMost (readBinIface file_path) + ; ioToIOEnv $ do + { res <- tryMost (readBinIface file_path) ; case res of - Right iface -> return (Succeeded iface) - Left exn -> return (Failed (text (showException exn))) } - where - loc = mkSrcLoc (mkFastString file_path) 1 0 + Right iface + | wanted_mod == actual_mod -> return (Succeeded iface) + | otherwise -> return (Failed err) + where + actual_mod = mi_module iface + err = hiModuleNameMismatchWarn wanted_mod actual_mod + + Left exn -> return (Failed (text (showException exn))) + }} \end{code} @@ -748,27 +726,6 @@ hiModuleNameMismatchWarn requested_mod read_mod = , ppr read_mod ] -noIfaceErr :: DynFlags -> Module -> FindResult -> SDoc -noIfaceErr dflags mod_name (PackageHidden pkg) - = ptext SLIT("Could not import") <+> quotes (ppr mod_name) <> colon - $$ ptext SLIT("it is a member of package") <+> ppr pkg <> comma - <+> ptext SLIT("which is hidden") - -noIfaceErr dflags mod_name (ModuleHidden pkg) - = ptext SLIT("Could not import") <+> quotes (ppr mod_name) <> colon - $$ ptext SLIT("it is hidden") - <+> parens (ptext SLIT("in package") <+> ppr pkg) - -noIfaceErr dflags mod_name (NotFound files) - = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name) - $$ extra files - where - extra files - | verbosity dflags < 3 = - text "(use -v to see a list of the files searched for)" - | otherwise = - hang (ptext SLIT("locations searched:")) 4 (vcat (map text files)) - wrongIfaceModErr iface mod_name file_path = sep [ptext SLIT("Interface file") <+> iface_file, ptext SLIT("contains module") <+> quotes (ppr (mi_module iface)) <> comma, diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index 8fa008f..a27335e 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -4,7 +4,7 @@ \begin{code} module MkIface ( - showIface, -- Print the iface in Foo.hi + pprModIface, showIface, -- Print the iface in Foo.hi mkUsageInfo, -- Construct the usage info for a module @@ -189,6 +189,7 @@ import HscTypes ( ModIface(..), TyThing(..), ModGuts(..), ModGuts, IfaceExport, GhciMode(..), HscEnv(..), hscEPS, Dependencies(..), FixItem(..), + ModSummary(..), msHiFilePath, mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, typeEnvElts, GenAvailInfo(..), availName, @@ -258,6 +259,7 @@ mkIface :: HscEnv mkIface hsc_env location maybe_old_iface guts@ModGuts{ mg_module = this_mod, + mg_boot = is_boot, mg_usages = usages, mg_deps = deps, mg_exports = exports, @@ -295,7 +297,7 @@ mkIface hsc_env location maybe_old_iface ; intermediate_iface = ModIface { mi_module = this_mod, mi_package = HomePackage, - mi_boot = False, + mi_boot = is_boot, mi_deps = deps, mi_usages = usages, mi_exports = mkIfaceExports exports, @@ -340,10 +342,10 @@ mkIface hsc_env location maybe_old_iface r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2 - dflags = hsc_dflags hsc_env - ghci_mode = hsc_mode hsc_env + dflags = hsc_dflags hsc_env + ghci_mode = hsc_mode hsc_env + omit_prags = dopt Opt_OmitInterfacePragmas dflags hi_file_path = ml_hi_file location - omit_prags = dopt Opt_OmitInterfacePragmas dflags mustExposeThing :: NameSet -> TyThing -> Bool @@ -799,21 +801,20 @@ mkIfaceExports exports \begin{code} checkOldIface :: HscEnv - -> Module - -> FilePath -- Where the interface file is + -> ModSummary -> Bool -- Source unchanged -> Maybe ModIface -- Old interface from compilation manager, if any -> IO (RecompileRequired, Maybe ModIface) -checkOldIface hsc_env mod iface_path source_unchanged maybe_iface +checkOldIface hsc_env mod_summary source_unchanged maybe_iface = do { showPass (hsc_dflags hsc_env) - ("Checking old interface for " ++ moduleUserString mod) ; + ("Checking old interface for " ++ moduleUserString (ms_mod mod_summary)) ; ; initIfaceCheck hsc_env $ - check_old_iface mod iface_path source_unchanged maybe_iface + check_old_iface mod_summary source_unchanged maybe_iface } -check_old_iface this_mod iface_path source_unchanged maybe_iface +check_old_iface mod_summary source_unchanged maybe_iface = -- CHECK WHETHER THE SOURCE HAS CHANGED ifM (not source_unchanged) (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) @@ -835,7 +836,10 @@ check_old_iface this_mod iface_path source_unchanged maybe_iface -- Try and read the old interface for the current module -- from the .hi file left from the last time we compiled it - readIface this_mod iface_path False `thenM` \ read_result -> + let + iface_path = msHiFilePath mod_summary + in + readIface (ms_mod mod_summary) iface_path False `thenM` \ read_result -> case read_result of { Failed err -> -- Old interface file not found, or garbled; give up traceIf (text "FYI: cannot read old interface file:" @@ -1016,8 +1020,8 @@ pprModIface :: ModIface -> SDoc pprModIface iface = vcat [ ptext SLIT("interface") <+> ppr_package (mi_package iface) - <+> ppr (mi_module iface) <+> ppr (mi_mod_vers iface) - <+> pp_sub_vers + <+> ppr (mi_module iface) <+> pp_boot + <+> ppr (mi_mod_vers iface) <+> pp_sub_vers <+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty) <+> int opt_HiVersion <+> ptext SLIT("where") @@ -1031,6 +1035,8 @@ pprModIface iface , pprDeprecs (mi_deprecs iface) ] where + pp_boot | mi_boot iface = ptext SLIT("[boot]") + | otherwise = empty ppr_package HomePackage = empty ppr_package (ExtPackage id) = doubleQuotes (ppr id) diff --git a/ghc/compiler/iface/TcIface.lhs-boot b/ghc/compiler/iface/TcIface.lhs-boot new file mode 100644 index 0000000..51a5f9f --- /dev/null +++ b/ghc/compiler/iface/TcIface.lhs-boot @@ -0,0 +1,9 @@ +\begin{code} +module TcIface where +import IfaceSyn ( IfaceDecl ) +import TypeRep ( TyThing ) +import TcRnTypes ( IfL ) + +tcIfaceDecl :: IfaceDecl -> IfL TyThing +\end{code} + diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 24e6d15..5fbf20d 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -10,7 +10,7 @@ module CmdLineOpts ( SimplifierSwitch(..), SimplifierMode(..), FloatOutSwitches(..), - HscLang(..), + HscTarget(..), DynFlag(..), -- needed non-abstractly by DriverFlags DynFlags(..), PackageFlag(..), @@ -25,7 +25,7 @@ module CmdLineOpts ( dopt_set, dopt_unset, -- DynFlags -> DynFlag -> DynFlags dopt_CoreToDo, -- DynFlags -> [CoreToDo] dopt_StgToDo, -- DynFlags -> [StgToDo] - dopt_HscLang, -- DynFlags -> HscLang + dopt_HscTarget, -- DynFlags -> HscTarget dopt_OutName, -- DynFlags -> String getOpts, -- (DynFlags -> [a]) -> IO [a] getVerbFlag, @@ -90,6 +90,7 @@ module CmdLineOpts ( #include "HsVersions.h" import {-# SOURCE #-} Packages (PackageState) +import DriverPhases ( HscTarget(..), HscSource(..) ) import Constants -- Default values for some flags import Util import FastString ( FastString, mkFastString ) @@ -294,7 +295,7 @@ data DynFlag data DynFlags = DynFlags { coreToDo :: Maybe [CoreToDo], -- reserved for use with -Ofile stgToDo :: [StgToDo], - hscLang :: HscLang, + hscTarget :: HscTarget, hscOutName :: String, -- name of the output file hscStubHOutName :: String, -- name of the .stub_h output file hscStubCOutName :: String, -- name of the .stub_c output file @@ -345,25 +346,16 @@ data PackageFlag | HidePackage String | IgnorePackage String -data HscLang - = HscC - | HscAsm - | HscJava - | HscILX - | HscInterpreted - | HscNothing - deriving (Eq, Show) - -defaultHscLang +defaultHscTarget | cGhcWithNativeCodeGen == "YES" && (prefixMatch "i386" cTARGETPLATFORM || prefixMatch "sparc" cTARGETPLATFORM || - prefixMatch "powerpc" cTARGETPLATFORM) = HscAsm + prefixMatch "powerpc" cTARGETPLATFORM) = HscAsm | otherwise = HscC defaultDynFlags = DynFlags { coreToDo = Nothing, stgToDo = [], - hscLang = defaultHscLang, + hscTarget = defaultHscTarget, hscOutName = "", hscStubHOutName = "", hscStubCOutName = "", extCoreName = "", @@ -440,8 +432,8 @@ dopt_StgToDo = stgToDo dopt_OutName :: DynFlags -> String dopt_OutName = hscOutName -dopt_HscLang :: DynFlags -> HscLang -dopt_HscLang = hscLang +dopt_HscTarget :: DynFlags -> HscTarget +dopt_HscTarget = hscTarget dopt_set :: DynFlags -> DynFlag -> DynFlags dopt_set dfs f = dfs{ flags = f : flags dfs } @@ -462,7 +454,7 @@ getVerbFlag dflags updOptLevel n dfs = if (n >= 1) - then dfs2{ hscLang = HscC, optLevel = n } -- turn on -fvia-C with -O + then dfs2{ hscTarget = HscC, optLevel = n } -- turn on -fvia-C with -O else dfs2{ optLevel = n } where dfs1 = foldr (flip dopt_unset) dfs remove_dopts @@ -740,7 +732,6 @@ opt_SccProfilingOn = lookUp FSLIT("-fscc-profiling") opt_DoTickyProfiling = lookUp FSLIT("-fticky-ticky") -- language opts -opt_AllStrict = lookUp FSLIT("-fall-strict") opt_DictsStrict = lookUp FSLIT("-fdicts-strict") opt_IrrefutableTuples = lookUp FSLIT("-firrefutable-tuples") opt_MaxContextReductionDepth = lookup_def_int "-fcontext-stack" mAX_CONTEXT_REDUCTION_DEPTH @@ -861,10 +852,4 @@ startsWith [] str = Just str startsWith (c:cs) (s:ss) = if c /= s then Nothing else startsWith cs ss startsWith _ [] = Nothing - -endsWith :: String -> String -> Maybe String -endsWith cs ss - = case (startsWith (reverse cs) (reverse ss)) of - Nothing -> Nothing - Just rs -> Just (reverse rs) \end{code} diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 2c37777..5f7f395 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -80,7 +80,7 @@ codeOutput dflags this_mod foreign_stubs deps flat_abstractC ; showPass dflags "CodeOutput" ; let filenm = dopt_OutName dflags ; stubs_exist <- outputForeignStubs dflags foreign_stubs - ; case dopt_HscLang dflags of { + ; case dopt_HscTarget dflags of { HscInterpreted -> return (); HscAsm -> outputAsm dflags filenm flat_abstractC; HscC -> outputC dflags filenm flat_abstractC stubs_exist diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 6d24d53..82c288b 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -177,11 +177,10 @@ static_flags = ------- primary modes ------------------------------------------------ , ( "M" , PassFlag (setMode DoMkDependHS)) - , ( "E" , PassFlag (setMode (StopBefore Hsc))) + , ( "E" , PassFlag (setMode (StopBefore anyHsc))) , ( "C" , PassFlag (\f -> do setMode (StopBefore HCc) f - setLang HscC)) + setTarget HscC)) , ( "S" , PassFlag (setMode (StopBefore As))) - , ( "c" , PassFlag (setMode (StopBefore Ln))) , ( "-make" , PassFlag (setMode DoMake)) , ( "-interactive" , PassFlag (setMode DoInteractive)) , ( "-mk-dll" , PassFlag (setMode DoMkDLL)) @@ -189,7 +188,7 @@ static_flags = -- -fno-code says to stop after Hsc but don't generate any code. , ( "fno-code" , PassFlag (\f -> do setMode (StopBefore HCc) f - setLang HscNothing + setTarget HscNothing writeIORef v_Recomp False)) ------- GHCi ------------------------------------------------------- @@ -241,8 +240,8 @@ static_flags = , ( "odir" , HasArg (writeIORef v_Output_dir . Just) ) , ( "o" , SepArg (writeIORef v_Output_file . Just) ) , ( "osuf" , HasArg (writeIORef v_Object_suf) ) - , ( "hcsuf" , HasArg (writeIORef v_HC_suf . Just) ) - , ( "hisuf" , HasArg (writeIORef v_Hi_suf) ) + , ( "hcsuf" , HasArg (writeIORef v_HC_suf ) ) + , ( "hisuf" , HasArg (writeIORef v_Hi_suf ) ) , ( "hidir" , HasArg (writeIORef v_Hi_dir . Just) ) , ( "buildtag" , HasArg (writeIORef v_Build_tag) ) , ( "tmpdir" , HasArg setTmpDir) @@ -298,7 +297,8 @@ static_flags = , ( "optdll" , HasArg (add v_Opt_dll) ) ----- Linker -------------------------------------------------------- - , ( "no-link" , NoArg (writeIORef v_NoLink True) ) + , ( "c" , NoArg (writeIORef v_NoLink True) ) + , ( "no-link" , NoArg (writeIORef v_NoLink True) ) -- Deprecated , ( "static" , NoArg (writeIORef v_Static True) ) , ( "dynamic" , NoArg (writeIORef v_Static False) ) , ( "rdynamic" , NoArg (return ()) ) -- ignored for compat w/ gcc @@ -429,10 +429,10 @@ dynamic_flags = [ ------ Compiler flags ----------------------------------------------- - , ( "fasm", AnySuffix (\_ -> setLang HscAsm) ) - , ( "fvia-c", NoArg (setLang HscC) ) - , ( "fvia-C", NoArg (setLang HscC) ) - , ( "filx", NoArg (setLang HscILX) ) + , ( "fasm", AnySuffix (\_ -> setTarget HscAsm) ) + , ( "fvia-c", NoArg (setTarget HscC) ) + , ( "fvia-C", NoArg (setTarget HscC) ) + , ( "filx", NoArg (setTarget HscILX) ) , ( "fglasgow-exts", NoArg (mapM_ setDynFlag glasgowExtsFlags) ) , ( "fno-glasgow-exts", NoArg (mapM_ unSetDynFlag glasgowExtsFlags) ) @@ -549,16 +549,16 @@ addImportPath p = do -- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags -- (-fvia-C, -fasm, -filx respectively). -setLang l = updDynFlags (\dfs -> case hscLang dfs of - HscC -> dfs{ hscLang = l } - HscAsm -> dfs{ hscLang = l } - HscILX -> dfs{ hscLang = l } +setTarget l = updDynFlags (\dfs -> case hscTarget dfs of + HscC -> dfs{ hscTarget = l } + HscAsm -> dfs{ hscTarget = l } + HscILX -> dfs{ hscTarget = l } _ -> dfs) setOptLevel :: Int -> IO () setOptLevel n = do dflags <- readIORef v_DynFlags - if hscLang dflags == HscInterpreted && n > 0 + if hscTarget dflags == HscInterpreted && n > 0 then putStr "warning: -O conflicts with --interactive; -O ignored.\n" else writeIORef v_DynFlags (updOptLevel n dflags) @@ -736,8 +736,8 @@ showGhcUsage = do (ghc_usage_path,ghci_usage_path) <- getUsageMsgPaths mode <- readIORef v_GhcMode let usage_path - | mode == DoInteractive = ghci_usage_path - | otherwise = ghc_usage_path + | DoInteractive <- mode = ghci_usage_path + | otherwise = ghc_usage_path usage <- readFile usage_path dump usage exitWith ExitSuccess diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index 73fba48..7d13a70 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverMkDepend.hs,v 1.36 2005/01/18 12:18:28 simonpj Exp $ +-- $Id: DriverMkDepend.hs,v 1.37 2005/01/27 10:44:27 simonpj Exp $ -- -- GHC Driver -- @@ -8,23 +8,26 @@ ----------------------------------------------------------------------------- module DriverMkDepend ( - doMkDependHSPhase, beginMkDependHS, endMkDependHS + doMkDependHS ) where #include "HsVersions.h" -import GetImports ( getImportsFromFile ) -import CmdLineOpts ( DynFlags ) -import DriverState -import DriverUtil -import DriverFlags +import CompManager ( cmInit, cmDepAnal, cmTopSort, cyclicModuleErr ) +import CmdLineOpts ( DynFlags( verbosity ) ) +import DriverState ( getStaticOpts, v_Opt_dep ) +import DriverUtil ( escapeSpaces, splitFilename, add ) +import DriverFlags ( processArgs, OptKind(..) ) +import HscTypes ( IsBootInterface, ModSummary(..), GhciMode(..), + msObjFilePath, msHsFilePath ) import Packages ( PackageIdH(..) ) import SysTools ( newTempName ) import qualified SysTools -import Module ( Module, ModLocation(..), moduleUserString) -import Finder ( findModule, hiBootExt, hiBootVerExt, - mkHomeModLocation, FindResult(..) ) -import Util ( global, maybePrefixMatch ) +import Module ( Module, ModLocation(..), moduleUserString, addBootSuffix_maybe ) +import Digraph ( SCC(..) ) +import Finder ( findModule, FindResult(..) ) +import Util ( global ) +import Outputable import Panic import DATA_IOREF ( IORef, readIORef, writeIORef ) @@ -39,60 +42,72 @@ import Maybe ( isJust ) import Panic ( catchJust, ioErrors ) #endif -------------------------------------------------------------------------------- --- mkdependHS - - -- flags -GLOBAL_VAR(v_Dep_makefile, "Makefile", String); -GLOBAL_VAR(v_Dep_include_prelude, False, Bool); -GLOBAL_VAR(v_Dep_exclude_mods, ["GHC.Prim"], [String]); -GLOBAL_VAR(v_Dep_suffixes, [], [String]); -GLOBAL_VAR(v_Dep_warnings, True, Bool); - - -- global vars -GLOBAL_VAR(v_Dep_makefile_hdl, error "dep_makefile_hdl", Maybe Handle); -GLOBAL_VAR(v_Dep_tmp_file, error "dep_tmp_file", String); -GLOBAL_VAR(v_Dep_tmp_hdl, error "dep_tmp_hdl", Handle); - -depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" -depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" +----------------------------------------------------------------- +-- +-- The main function +-- +----------------------------------------------------------------- + +doMkDependHS :: DynFlags -> [FilePath] -> IO () +doMkDependHS dflags srcs + = do { -- Initialisation + cm_state <- cmInit Batch dflags + ; files <- beginMkDependHS + + -- Do the downsweep to find all the modules + ; mod_summaries <- cmDepAnal cm_state srcs + + -- Sort into dependency order + -- There should be no cycles + ; let sorted = cmTopSort False mod_summaries + + -- Print out the dependencies if wanted + ; if verbosity dflags >= 3 then + hPutStrLn stderr (showSDoc (text "Module dependencies" $$ ppr sorted)) + else return () + + -- Prcess them one by one, dumping results into makefile + -- and complaining about cycles + ; mapM (processDeps dflags (mkd_tmp_hdl files)) sorted + + -- Tidy up + ; endMkDependHS dflags files } + +----------------------------------------------------------------- +-- +-- beginMkDependHs +-- Create a temporary file, +-- find the Makefile, +-- slurp through it, etc +-- +----------------------------------------------------------------- --- for compatibility with the old mkDependHS, we accept options of the form --- -optdep-f -optdep.depend, etc. -dep_opts = - [ ( "s", SepArg (add v_Dep_suffixes) ) - , ( "f", SepArg (writeIORef v_Dep_makefile) ) - , ( "w", NoArg (writeIORef v_Dep_warnings False) ) - , ( "-include-prelude", NoArg (writeIORef v_Dep_include_prelude True) ) - , ( "-exclude-module=", Prefix (add v_Dep_exclude_mods) ) - , ( "x", Prefix (add v_Dep_exclude_mods) ) - ] +data MkDepFiles + = MkDep { mkd_make_file :: FilePath, -- Name of the makefile + mkd_make_hdl :: Maybe Handle, -- Handle for the open makefile + mkd_tmp_file :: FilePath, -- Name of the temporary file + mkd_tmp_hdl :: Handle } -- Handle of the open temporary file -beginMkDependHS :: IO () +beginMkDependHS :: IO MkDepFiles + beginMkDependHS = do - -- slurp in the mkdependHS-style options flags <- getStaticOpts v_Opt_dep _ <- processArgs dep_opts flags [] -- open a new temp file in which to stuff the dependency info -- as we go along. - dep_file <- newTempName "dep" - writeIORef v_Dep_tmp_file dep_file - tmp_hdl <- openFile dep_file WriteMode - writeIORef v_Dep_tmp_hdl tmp_hdl + tmp_file <- newTempName "dep" + tmp_hdl <- openFile tmp_file WriteMode -- open the makefile makefile <- readIORef v_Dep_makefile exists <- doesFileExist makefile - if not exists - then do - writeIORef v_Dep_makefile_hdl Nothing - return () - + mb_make_hdl <- + if not exists + then return Nothing else do makefile_hdl <- openFile makefile ReadMode - writeIORef v_Dep_makefile_hdl (Just makefile_hdl) -- slurp through until we get the magic start string, -- copying the contents into dep_makefile @@ -115,47 +130,124 @@ beginMkDependHS = do catchJust ioErrors chuck (\e -> if isEOFError e then return () else ioError e) + return (Just makefile_hdl) + -- write the magic marker into the tmp file hPutStrLn tmp_hdl depStartMarker - return () - - -doMkDependHSPhase dflags basename suff input_fn - = do (import_sources, import_normals, mod_name) - <- getImportsFromFile dflags input_fn - let orig_fn = basename ++ '.':suff - location' <- mkHomeModLocation mod_name orig_fn - - -- take -ohi into account if present - ohi <- readIORef v_Output_hi - let location | Just fn <- ohi = location'{ ml_hi_file = fn } - | otherwise = location' + return (MkDep { mkd_make_file = makefile, mkd_make_hdl = mb_make_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl}) - deps_sources <- mapM (findDependency dflags True orig_fn) import_sources - deps_normals <- mapM (findDependency dflags False orig_fn) import_normals - let deps = deps_sources ++ deps_normals - osuf <- readIORef v_Object_suf - extra_suffixes <- readIORef v_Dep_suffixes - let suffixes = map (++ ('_':osuf)) extra_suffixes - obj_file = ml_obj_file location - objs = obj_file : map (replaceFilenameSuffix obj_file) suffixes - - -- Handle for file that accumulates dependencies - hdl <- readIORef v_Dep_tmp_hdl - - -- std dependency of the object(s) on the source file - hPutStrLn hdl (unwords (map escapeSpaces objs) ++ " : " ++ - escapeSpaces (basename ++ '.':suff)) +----------------------------------------------------------------- +-- +-- processDeps +-- +----------------------------------------------------------------- + +processDeps :: DynFlags + -> Handle -- Write dependencies to here + -> SCC ModSummary + -> IO () +-- Write suitable dependencies to handle +-- Always: +-- this.o : this.hs +-- +-- If the dependency is on something other than a .hi file: +-- this.o this.p_o ... : dep +-- otherwise +-- this.o ... : dep.hi +-- this.p_o ... : dep.p_hi +-- ... +-- (where .o is $osuf, and the other suffixes come from +-- the cmdline -s options). +-- +-- For {-# SOURCE #-} imports the "hi" will be "hi-boot". + +processDeps dflags hdl (CyclicSCC nodes) + = -- There shouldn't be any cycles; report them + throwDyn (ProgramError (showSDoc $ cyclicModuleErr nodes)) + +processDeps dflags hdl (AcyclicSCC node) + = do { extra_suffixes <- readIORef v_Dep_suffixes + ; let src_file = msHsFilePath node + obj_file = msObjFilePath node + obj_files = insertSuffixes obj_file extra_suffixes + + do_imp is_boot imp_mod + = do { mb_hi <- findDependency dflags src_file imp_mod is_boot + ; case mb_hi of { + Nothing -> return () ; + Just hi_file -> do + { let hi_files = insertSuffixes hi_file extra_suffixes + write_dep (obj,hi) = writeDependency hdl [obj] hi + + -- Add one dependency for each suffix; + -- e.g. A.o : B.hi + -- A.x_o : B.x_hi + ; mapM_ write_dep (obj_files `zip` hi_files) }}} + + + -- Emit std dependency of the object(s) on the source file + -- Something like A.o : A.hs + ; writeDependency hdl obj_files src_file + + -- Emit a dependency for each import + ; mapM_ (do_imp True) (ms_srcimps node) -- SOURCE imports + ; mapM_ (do_imp False) (ms_imps node) -- regular imports + } + + +findDependency :: DynFlags + -> FilePath -- Importing module: used only for error msg + -> Module -- Imported module + -> IsBootInterface -- Source import + -> IO (Maybe FilePath) -- Interface file file +findDependency dflags src imp is_boot + = do { excl_mods <- readIORef v_Dep_exclude_mods + ; include_prelude <- readIORef v_Dep_include_prelude + + -- Deal with the excluded modules + ; let imp_mod = moduleUserString imp + ; if imp_mod `elem` excl_mods + then return Nothing + else do + { -- Find the module; this will be fast because + -- we've done it once during downsweep + r <- findModule dflags imp True {-explicit-} + ; case r of + Found loc pkg + -- Not in this package: we don't need a dependency + | ExtPackage _ <- pkg, not include_prelude + -> return Nothing - let genDep (dep, False {- not an hi file -}) = - hPutStrLn hdl (unwords (map escapeSpaces objs) ++ " : " ++ - escapeSpaces dep) - genDep (dep, True {- is an hi file -}) = do - hisuf <- readIORef v_Hi_suf - let + -- Home package: just depend on the .hi or hi-boot file + | otherwise + -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) + + _ -> throwDyn (ProgramError + (src ++ ": " ++ "can't locate import `" ++ imp_mod ++ "'" + ++ if is_boot then " (SOURCE import)" else "")) + }} + +----------------------------- +writeDependency :: Handle -> [FilePath] -> FilePath -> IO () +-- (writeDependency h [t1,t2] dep) writes to handle h the dependency +-- t1 t2 : dep +writeDependency hdl targets dep + = hPutStrLn hdl (unwords (map escapeSpaces targets) ++ " : " + ++ escapeSpaces dep) + +----------------------------- +insertSuffixes + :: FilePath -- Original filename; e.g. "foo.o" + -> [String] -- Extra suffices e.g. ["x","y"] + -> [FilePath] -- Zapped filenames e.g. ["foo.o", "foo.x_o", "foo.y_o"] + -- Note that that the extra bit gets inserted *before* the old suffix + -- We assume the old suffix contains no dots, so we can strip it with removeSuffix + + -- NOTE: we used to have this comment -- In order to construct hi files with alternate suffixes, we -- now have to find the "basename" of the hi file. This is -- difficult because we can't just split the hi filename @@ -163,114 +255,79 @@ doMkDependHSPhase dflags basename suff input_fn -- check whether the hi filename ends in hisuf, and if it does, -- we strip off hisuf, otherwise we strip everything after the -- last dot. - dep_base - | Just rest <- maybePrefixMatch rev_hisuf rev_dep - = reverse rest - | otherwise - = remove_suffix '.' dep - where - rev_hisuf = reverse hisuf - rev_dep = reverse dep - - deps = dep : map (\suf -> dep_base ++ suf ++ '_':hisuf) - extra_suffixes - -- length objs should be == length deps - sequence_ (zipWith (\o d -> hPutStrLn hdl (escapeSpaces o ++ " : " ++ escapeSpaces d)) objs deps) - - sequence_ (map genDep [ d | Just d <- deps ]) - return location - --- add the lines to dep_makefile: - -- always: - -- this.o : this.hs - - -- if the dependency is on something other than a .hi file: - -- this.o this.p_o ... : dep - -- otherwise - -- if the import is {-# SOURCE #-} - -- this.o this.p_o ... : dep.hi-boot[-$vers] - - -- else - -- this.o ... : dep.hi - -- this.p_o ... : dep.p_hi - -- ... - - -- (where .o is $osuf, and the other suffixes come from - -- the cmdline -s options). - - - -endMkDependHS :: DynFlags -> IO () -endMkDependHS dflags = do - makefile <- readIORef v_Dep_makefile - makefile_hdl <- readIORef v_Dep_makefile_hdl - tmp_file <- readIORef v_Dep_tmp_file - tmp_hdl <- readIORef v_Dep_tmp_hdl + -- But I'm not sure we care about hisufs with dots in them. + -- Lots of other things will break first! - -- write the magic marker into the tmp file - hPutStrLn tmp_hdl depEndMarker +insertSuffixes file_name extras + = file_name : [ basename ++ "." ++ extra ++ "_" ++ suffix | extra <- extras ] + where + (basename, suffix) = splitFilename file_name + + +----------------------------------------------------------------- +-- +-- endMkDependHs +-- Complete the makefile, close the tmp file etc +-- +----------------------------------------------------------------- - case makefile_hdl of - Nothing -> return () - Just hdl -> do +endMkDependHS :: DynFlags -> MkDepFiles -> IO () +endMkDependHS dflags (MkDep { mkd_make_file = make_file, mkd_make_hdl = makefile_hdl, + mkd_tmp_file = tmp_file, mkd_tmp_hdl = tmp_hdl }) + = do { -- write the magic marker into the tmp file + hPutStrLn tmp_hdl depEndMarker + + ; case makefile_hdl of + Nothing -> return () + Just hdl -> do + { -- slurp the rest of the original makefile and copy it into the output - let slurp = do + let slurp = do l <- hGetLine hdl hPutStrLn tmp_hdl l slurp - catchJust ioErrors slurp + ; catchJust ioErrors slurp (\e -> if isEOFError e then return () else ioError e) - hClose hdl + ; hClose hdl - hClose tmp_hdl -- make sure it's flushed + ; hClose tmp_hdl -- make sure it's flushed - -- Create a backup of the original makefile - when (isJust makefile_hdl) - (SysTools.copy dflags ("Backing up " ++ makefile) - makefile (makefile++".bak")) + -- Create a backup of the original makefile + ; when (isJust makefile_hdl) + (SysTools.copy dflags ("Backing up " ++ make_file) + make_file (make_file++".bak")) - -- Copy the new makefile in place - SysTools.copy dflags "Installing new makefile" tmp_file makefile + -- Copy the new makefile in place + ; SysTools.copy dflags "Installing new makefile" tmp_file make_file + }} -findDependency :: DynFlags -> Bool -> FilePath -> Module -> IO (Maybe (String, Bool)) -findDependency dflags is_source src imp = do - excl_mods <- readIORef v_Dep_exclude_mods - include_prelude <- readIORef v_Dep_include_prelude - let imp_mod = moduleUserString imp - if imp_mod `elem` excl_mods - then return Nothing - else do - r <- findModule dflags imp True{-explicit-} - case r of - Found loc pkg - -- not in this package: we don't need a dependency - | ExtPackage _ <- pkg, not include_prelude - -> return Nothing +----------------------------------------------------------------- +-- +-- Flags +-- +----------------------------------------------------------------- + + -- Flags +GLOBAL_VAR(v_Dep_makefile, "Makefile", String); +GLOBAL_VAR(v_Dep_include_prelude, False, Bool); +GLOBAL_VAR(v_Dep_exclude_mods, ["GHC.Prim"], [String]); +GLOBAL_VAR(v_Dep_suffixes, [], [String]); +GLOBAL_VAR(v_Dep_warnings, True, Bool); - -- normal import: just depend on the .hi file - | not is_source - -> return (Just (ml_hi_file loc, not is_source)) +depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" +depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" - -- if it's a source import, we want to generate a dependency - -- on the .hi-boot file, not the .hi file - | otherwise - -> let hi_file = ml_hi_file loc - boot_hi_file = replaceFilenameSuffix hi_file hiBootExt - boot_ver_hi_file = replaceFilenameSuffix hi_file hiBootVerExt - in do - b <- doesFileExist boot_ver_hi_file - if b - then return (Just (boot_ver_hi_file, not is_source)) - else do - b <- doesFileExist boot_hi_file - if b - then return (Just (boot_hi_file, not is_source)) - else return (Just (hi_file, not is_source)) - - _ -> throwDyn (ProgramError - (src ++ ": " ++ "can't locate import `" ++ imp_mod ++ "'" ++ - if is_source then " (SOURCE import)" else "")) +-- for compatibility with the old mkDependHS, we accept options of the form +-- -optdep-f -optdep.depend, etc. +dep_opts = + [ ( "s", SepArg (add v_Dep_suffixes) ) + , ( "f", SepArg (writeIORef v_Dep_makefile) ) + , ( "w", NoArg (writeIORef v_Dep_warnings False) ) + , ( "-include-prelude", NoArg (writeIORef v_Dep_include_prelude True) ) + , ( "-exclude-module=", Prefix (add v_Dep_exclude_mods) ) + , ( "x", Prefix (add v_Dep_exclude_mods) ) + ] diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs index 37d73d3..0b1c415 100644 --- a/ghc/compiler/main/DriverPhases.hs +++ b/ghc/compiler/main/DriverPhases.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverPhases.hs,v 1.31 2005/01/18 13:51:28 simonmar Exp $ +-- $Id: DriverPhases.hs,v 1.32 2005/01/27 10:44:27 simonpj Exp $ -- -- GHC Driver -- @@ -10,8 +10,9 @@ #include "../includes/ghcconfig.h" module DriverPhases ( - Phase(..), - happensBefore, + HscSource(..), isHsBoot, hscSourceString, + HscTarget(..), Phase(..), + happensBefore, eqPhase, anyHsc, isStopPhase, startPhase, -- :: String -> Phase phaseInputExt, -- :: Phase -> String @@ -26,6 +27,7 @@ module DriverPhases ( ) where import DriverUtil +import Panic ( panic ) ----------------------------------------------------------------------------- -- Phases @@ -42,87 +44,157 @@ import DriverUtil linker | other | - | a.out -} +data HscSource + = HsSrcFile | HsBootFile | ExtCoreFile + deriving( Eq, Ord, Show ) + -- Ord needed for the finite maps we build in CompManager + + +hscSourceString :: HscSource -> String +hscSourceString HsSrcFile = "" +hscSourceString HsBootFile = "[boot]" +hscSourceString ExtCoreFile = "[ext core]" + +isHsBoot :: HscSource -> Bool +isHsBoot HsBootFile = True +isHsBoot other = False + +data HscTarget + = HscC + | HscAsm + | HscJava + | HscILX + | HscInterpreted + | HscNothing + deriving (Eq, Show) + data Phase - = Unlit - | Cpp - | HsPp - | Hsc + = Unlit HscSource + | Cpp HscSource + | HsPp HscSource + | Hsc HscSource | Cc | HCc -- Haskellised C (as opposed to vanilla C) compilation | Mangle -- assembly mangling, now done by a separate script. | SplitMangle -- after mangler if splitting | SplitAs | As - | Ln | CmmCpp -- pre-process Cmm source | Cmm -- parse & compile Cmm code #ifdef ILX | Ilx2Il | Ilasm #endif - deriving (Eq, Show) + + -- The final phase is a pseudo-phase that tells the pipeline to stop. + -- There is no runPhase case for it. + | StopLn -- Stop, but linking will follow, so generate .o file + + deriving (Show) + +anyHsc :: Phase +anyHsc = Hsc (panic "anyHsc") + +isStopPhase :: Phase -> Bool +isStopPhase StopLn = True +isStopPhase other = False + +eqPhase :: Phase -> Phase -> Bool +-- Equality of constructors, ignoring the HscSource field +eqPhase (Unlit _) (Unlit _) = True +eqPhase (Cpp _) (Cpp _) = True +eqPhase (HsPp _) (HsPp _) = True +eqPhase (Hsc _) (Hsc _) = True +eqPhase Cc Cc = True +eqPhase HCc HCc = True +eqPhase Mangle Mangle = True +eqPhase SplitMangle SplitMangle = True +eqPhase SplitAs SplitAs = True +eqPhase As As = True +eqPhase CmmCpp CmmCpp = True +eqPhase Cmm Cmm = True +eqPhase StopLn StopLn = True +eqPhase _ _ = False -- Partial ordering on phases: we want to know which phases will occur before -- which others. This is used for sanity checking, to ensure that the -- pipeline will stop at some point (see DriverPipeline.runPipeline). -x `happensBefore` y - | x `elem` haskell_pipe = y `elem` tail (dropWhile (/= x) haskell_pipe) - | x `elem` cmm_pipe = y `elem` tail (dropWhile (/= x) cmm_pipe) - | x `elem` c_pipe = y `elem` tail (dropWhile (/= x) c_pipe) - | otherwise = False - -haskell_post_hsc = [HCc,Mangle,SplitMangle,As,SplitAs,Ln] -haskell_pipe = Unlit : Cpp : HsPp : Hsc : haskell_post_hsc -cmm_pipe = CmmCpp : Cmm : haskell_post_hsc -c_pipe = [Cc,As,Ln] +StopLn `happensBefore` y = False +x `happensBefore` y = after_x `eqPhase` y || after_x `happensBefore` y + where + after_x = nextPhase x + +nextPhase :: Phase -> Phase +-- A conservative approximation the next phase, used in happensBefore +nextPhase (Unlit sf) = Cpp sf +nextPhase (Cpp sf) = HsPp sf +nextPhase (HsPp sf) = Hsc sf +nextPhase (Hsc sf) = HCc +nextPhase HCc = Mangle +nextPhase Mangle = SplitMangle +nextPhase SplitMangle = As +nextPhase As = SplitAs +nextPhase SplitAs = StopLn +nextPhase Cc = As +nextPhase CmmCpp = Cmm +nextPhase Cmm = HCc +nextPhase StopLn = panic "nextPhase: nothing after StopLn" -- the first compilation phase for a given file is determined -- by its suffix. -startPhase "lhs" = Unlit -startPhase "hs" = Cpp -startPhase "hscpp" = HsPp -startPhase "hspp" = Hsc -startPhase "hcr" = Hsc -startPhase "hc" = HCc -startPhase "c" = Cc -startPhase "cpp" = Cc -startPhase "C" = Cc -startPhase "cc" = Cc -startPhase "cxx" = Cc -startPhase "raw_s" = Mangle -startPhase "s" = As -startPhase "S" = As -startPhase "o" = Ln -startPhase "cmm" = CmmCpp -startPhase "cmmcpp" = Cmm -startPhase _ = Ln -- all unknown file types +startPhase "lhs" = Unlit HsSrcFile +startPhase "lhs-boot" = Unlit HsBootFile +startPhase "hs" = Cpp HsSrcFile +startPhase "hs-boot" = Cpp HsBootFile +startPhase "hscpp" = HsPp HsSrcFile +startPhase "hspp" = Hsc HsSrcFile +startPhase "hcr" = Hsc ExtCoreFile +startPhase "hc" = HCc +startPhase "c" = Cc +startPhase "cpp" = Cc +startPhase "C" = Cc +startPhase "cc" = Cc +startPhase "cxx" = Cc +startPhase "raw_s" = Mangle +startPhase "s" = As +startPhase "S" = As +startPhase "o" = StopLn +startPhase "cmm" = CmmCpp +startPhase "cmmcpp" = Cmm +startPhase _ = StopLn -- all unknown file types -- This is used to determine the extension for the output from the -- current phase (if it generates a new file). The extension depends -- on the next phase in the pipeline. -phaseInputExt Unlit = "lhs" -phaseInputExt Cpp = "lpp" -- intermediate only -phaseInputExt HsPp = "hscpp" -phaseInputExt Hsc = "hspp" -phaseInputExt HCc = "hc" -phaseInputExt Cc = "c" -phaseInputExt Mangle = "raw_s" -phaseInputExt SplitMangle = "split_s" -- not really generated -phaseInputExt As = "s" -phaseInputExt SplitAs = "split_s" -- not really generated -phaseInputExt Ln = "o" -phaseInputExt CmmCpp = "cmm" -phaseInputExt Cmm = "cmmcpp" +phaseInputExt (Unlit HsSrcFile) = "lhs" +phaseInputExt (Unlit HsBootFile) = "lhs-boot" +phaseInputExt (Unlit ExtCoreFile) = "lhcr" +phaseInputExt (Cpp _) = "lpp" -- intermediate only +phaseInputExt (HsPp _) = "hscpp" -- intermediate only +phaseInputExt (Hsc _) = "hspp" -- intermediate only + -- NB: as things stand, phaseInputExt (Hsc x) must not evaluate x + -- because runPipeline uses the StopBefore phase to pick the + -- output filename. That could be fixed, but watch out. +phaseInputExt HCc = "hc" +phaseInputExt Cc = "c" +phaseInputExt Mangle = "raw_s" +phaseInputExt SplitMangle = "split_s" -- not really generated +phaseInputExt As = "s" +phaseInputExt SplitAs = "split_s" -- not really generated +phaseInputExt CmmCpp = "cmm" +phaseInputExt Cmm = "cmmcpp" +phaseInputExt StopLn = "o" #ifdef ILX -phaseInputExt Ilx2Il = "ilx" -phaseInputExt Ilasm = "il" +phaseInputExt Ilx2Il = "ilx" +phaseInputExt Ilasm = "il" #endif -haskellish_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr", "hc", "raw_s", "cmm" ] -haskellish_src_suffixes = [ "hs", "lhs", "hspp", "hscpp", "hcr", "cmm" ] +haskellish_src_suffixes = haskellish_user_src_suffixes ++ + [ "hspp", "hscpp", "hcr", "cmm" ] +haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"] cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S" ] extcoreish_suffixes = [ "hcr" ] -haskellish_user_src_suffixes = [ "hs", "lhs" ] +haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ] -- Will not be deleted as temp files -- Use the appropriate suffix for the system on which -- the GHC-compiled code will run diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 3b9d399..5eb3f24 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -11,7 +11,7 @@ module DriverPipeline ( -- Interfaces for the batch-mode driver - runPipeline, staticLink, + compileFile, staticLink, -- Interfaces for the compilation manager (interpreted/batch-mode) preprocess, @@ -28,7 +28,6 @@ import Packages import GetImports import DriverState import DriverUtil -import DriverMkDepend import DriverPhases import DriverFlags import SysTools ( newTempName, addFilesToClean, getSysMan, copy ) @@ -53,7 +52,6 @@ import ParserCoreUtils ( getCoreModuleName ) import EXCEPTION import DATA_IOREF ( readIORef, writeIORef ) -import Time ( ClockTime ) import Directory import System import IO @@ -66,16 +64,43 @@ import Maybe -- Just preprocess a file, put the result in a temp. file (used by the -- compilation manager during the summary phase). +-- +-- We return the augmented DynFlags, because they contain the result +-- of slurping in the OPTIONS pragmas -preprocess :: DynFlags -> FilePath -> IO FilePath +preprocess :: DynFlags -> FilePath -> IO (DynFlags, FilePath) preprocess dflags filename = ASSERT2(isHaskellSrcFilename filename, text filename) - do runPipeline (StopBefore Hsc) dflags ("preprocess") + runPipeline (StopBefore anyHsc) dflags ("preprocess") False{-temporary output file-} Nothing{-no specific output file-} filename Nothing{-no ModLocation-} + + +-- --------------------------------------------------------------------------- +-- Compile a file +-- This is used in batch mode +compileFile :: GhcMode -> DynFlags -> FilePath -> IO FilePath +compileFile mode dflags src = do + exists <- doesFileExist src + when (not exists) $ + throwDyn (CmdLineError ("file `" ++ src ++ "' does not exist")) + + o_file <- readIORef v_Output_file + no_link <- readIORef v_NoLink -- Set by -c or -no-link + -- When linking, the -o argument refers to the linker's output. + -- otherwise, we use it as the name for the pipeline's output. + let maybe_o_file | no_link = o_file + | otherwise = Nothing + + stop_flag <- readIORef v_GhcModeFlag + (_, out_file) <- runPipeline mode dflags stop_flag True maybe_o_file + src Nothing{-no ModLocation-} + return out_file + + -- --------------------------------------------------------------------------- -- Compile @@ -95,12 +120,10 @@ preprocess dflags filename = -- NB. No old interface can also mean that the source has changed. compile :: HscEnv - -> Module - -> ModLocation - -> ClockTime -- timestamp of original source file - -> Bool -- True <=> source unchanged - -> Bool -- True <=> have object - -> Maybe ModIface -- old interface, if available + -> ModSummary + -> Bool -- True <=> source unchanged + -> Bool -- True <=> have object + -> Maybe ModIface -- Old interface, if available -> IO CompResult data CompResult @@ -115,22 +138,25 @@ data CompResult | CompErrs -compile hsc_env this_mod location src_timestamp - source_unchanged have_object - old_iface = do +compile hsc_env mod_summary + source_unchanged have_object old_iface = do - let dyn_flags = hsc_dflags hsc_env + let dyn_flags = hsc_dflags hsc_env + this_mod = ms_mod mod_summary + src_flavour = ms_hsc_src mod_summary - showPass dyn_flags - (showSDoc (text "Compiling" <+> ppr this_mod)) + showPass dyn_flags ("Compiling " ++ showModMsg have_object mod_summary) let verb = verbosity dyn_flags + let location = ms_location mod_summary let input_fn = expectJust "compile:hs" (ml_hs_file location) - let input_fnpp = expectJust "compile:hspp" (ml_hspp_file location) + let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary) when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp)) - -- add in the OPTIONS from the source file + -- Add in the OPTIONS from the source file + -- This is nasty: we've done this once already, in the compilation manager + -- It might be better to cache the flags in the ml_hspp_file field,say opts <- getOptionsFromSource input_fnpp (dyn_flags,unhandled_flags) <- processDynamicFlags opts dyn_flags checkProcessArgsResult unhandled_flags input_fn @@ -146,15 +172,16 @@ compile hsc_env this_mod location src_timestamp -- put back the old include paths afterward. later (writeIORef v_Include_paths old_paths) $ do - -- figure out what lang we're generating - hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags) - -- figure out what the next phase should be - next_phase <- hscNextPhase hsc_lang - -- figure out what file to generate the output into - get_output_fn <- genOutputFilenameFunc False Nothing next_phase basename - output_fn <- get_output_fn next_phase (Just location) + -- Figure out what lang we're generating + todo <- readIORef v_GhcMode + hsc_lang <- hscMaybeAdjustTarget todo src_flavour (hscTarget dyn_flags) + -- ... and what the next phase should be + next_phase <- hscNextPhase src_flavour hsc_lang + -- ... and what file to generate the output into + get_output_fn <- genOutputFilenameFunc next_phase False Nothing basename + output_fn <- get_output_fn next_phase (Just location) - let dyn_flags' = dyn_flags { hscLang = hsc_lang, + let dyn_flags' = dyn_flags { hscTarget = hsc_lang, hscOutName = output_fn, hscStubCOutName = basename ++ "_stub.c", hscStubHOutName = basename ++ "_stub.h", @@ -166,7 +193,7 @@ compile hsc_env this_mod location src_timestamp hsc_env' = hsc_env { hsc_dflags = dyn_flags' } -- run the compiler - hsc_result <- hscMain hsc_env' printErrorsAndWarnings this_mod location + hsc_result <- hscMain hsc_env' printErrorsAndWarnings mod_summary source_unchanged' have_object old_iface case hsc_result of @@ -175,7 +202,13 @@ compile hsc_env this_mod location src_timestamp HscNoRecomp details iface -> return (CompOK details Nothing iface Nothing) HscRecomp details rdr_env iface - stub_h_exists stub_c_exists maybe_interpreted_code -> do + stub_h_exists stub_c_exists maybe_interpreted_code + + | isHsBoot src_flavour -- No further compilation to do + -> return (CompOK details rdr_env iface Nothing) + + | otherwise -- Normal Haskell source files + -> do let maybe_stub_o <- compileStub dyn_flags' stub_c_exists let stub_unlinked = case maybe_stub_o of @@ -190,7 +223,7 @@ compile hsc_env this_mod location src_timestamp HscInterpreted -> case maybe_interpreted_code of #ifdef GHCI - Just comp_bc -> return ([BCOs comp_bc], src_timestamp) + Just comp_bc -> return ([BCOs comp_bc], ms_hs_date mod_summary) -- Why do we use the timestamp of the source file here, -- rather than the current time? This works better in -- the case where the local clock is out of sync @@ -204,8 +237,8 @@ compile hsc_env this_mod location src_timestamp _other -> do let object_filename = ml_obj_file location - runPipeline (StopBefore Ln) dyn_flags "" - True Nothing output_fn (Just location) + runPipeline DoLink dyn_flags "" + True Nothing output_fn (Just location) -- the object filename comes from the ModLocation o_time <- getModificationTime object_filename @@ -224,11 +257,11 @@ compileStub dflags stub_c_exists | stub_c_exists = do -- compile the _stub.c file w/ gcc let stub_c = hscStubCOutName dflags - stub_o <- runPipeline (StopBefore Ln) dflags "stub-compile" - True{-persistent output-} - Nothing{-no specific output file-} - stub_c - Nothing{-no ModLocation-} + (_, stub_o) <- runPipeline DoLink dflags "stub-compile" + True{-persistent output-} + Nothing{-no specific output file-} + stub_c + Nothing{-no ModLocation-} return (Just stub_o) @@ -274,7 +307,7 @@ link Batch dflags batch_attempt_linking hpt omit_linking <- readIORef v_NoLink if omit_linking then do when (verb >= 3) $ - hPutStrLn stderr "link(batch): linking omitted (-no-link flag given)." + hPutStrLn stderr "link(batch): linking omitted (-c flag given)." return Succeeded else do @@ -315,7 +348,7 @@ runPipeline -> Maybe FilePath -- where to put the output, optionally -> FilePath -- input filename -> Maybe ModLocation -- a ModLocation for this module, if we have one - -> IO FilePath -- output filename + -> IO (DynFlags, FilePath) -- (final flags, output filename) runPipeline todo dflags stop_flag keep_output maybe_output_filename input_fn maybe_loc @@ -324,12 +357,9 @@ runPipeline todo dflags stop_flag keep_output let (basename, suffix) = splitFilename input_fn start_phase = startPhase suffix - stop_phase = case todo of - StopBefore As | split -> SplitAs - StopBefore phase -> phase - DoMkDependHS -> Ln - DoLink -> Ln - DoMkDLL -> Ln + todo' = case todo of + StopBefore As | split -> StopBefore SplitAs + other -> todo -- We want to catch cases of "you can't get there from here" before -- we start the pipeline, because otherwise it will just run off the @@ -338,6 +368,10 @@ runPipeline todo dflags stop_flag keep_output -- There is a partial ordering on phases, where A < B iff A occurs -- before B in a normal compilation pipeline. -- + let stop_phase = case todo' of + StopBefore phase -> phase + other -> StopLn + when (not (start_phase `happensBefore` stop_phase)) $ throwDyn (UsageError ("flag `" ++ stop_flag @@ -346,63 +380,58 @@ runPipeline todo dflags stop_flag keep_output -- generate a function which will be used to calculate output file names -- as we go along. - get_output_fn <- genOutputFilenameFunc keep_output maybe_output_filename - stop_phase basename + get_output_fn <- genOutputFilenameFunc stop_phase keep_output + maybe_output_filename basename - -- and execute the pipeline... - (output_fn, maybe_loc) <- - pipeLoop dflags start_phase stop_phase input_fn basename suffix - get_output_fn maybe_loc + -- Execute the pipeline... + (dflags', output_fn, maybe_loc) <- pipeLoop todo' dflags start_phase stop_phase input_fn + basename suffix get_output_fn maybe_loc - -- sometimes, a compilation phase doesn't actually generate any output + -- Sometimes, a compilation phase doesn't actually generate any output -- (eg. the CPP phase when -fcpp is not turned on). If we end on this -- stage, but we wanted to keep the output, then we have to explicitly -- copy the file. - if keep_output + if keep_output then do final_fn <- get_output_fn stop_phase maybe_loc when (final_fn /= output_fn) $ copy dflags ("Copying `" ++ output_fn ++ "' to `" ++ final_fn ++ "'") output_fn final_fn - return final_fn + return (dflags', final_fn) else - return output_fn + return (dflags', output_fn) -pipeLoop :: DynFlags -> Phase -> Phase -> FilePath -> String -> Suffix - -> (Phase -> Maybe ModLocation -> IO FilePath) - -> Maybe ModLocation -> IO (FilePath, Maybe ModLocation) +pipeLoop :: GhcMode -> DynFlags -> Phase -> Phase + -> FilePath -> String -> Suffix + -> (Phase -> Maybe ModLocation -> IO FilePath) + -> Maybe ModLocation + -> IO (DynFlags, FilePath, Maybe ModLocation) -pipeLoop dflags phase stop_phase input_fn orig_basename orig_suff - get_output_fn maybe_loc +pipeLoop orig_todo dflags phase stop_phase + input_fn orig_basename orig_suff + orig_get_output_fn maybe_loc - | phase == stop_phase = return (input_fn, maybe_loc) -- all done + | phase `eqPhase` stop_phase -- All done + = return (dflags, input_fn, maybe_loc) - | not (phase `happensBefore` stop_phase) = + | not (phase `happensBefore` stop_phase) -- Something has gone wrong. We'll try to cover all the cases when -- this could happen, so if we reach here it is a panic. -- eg. it might happen if the -C flag is used on a source file that -- has {-# OPTIONS -fasm #-}. - panic ("pipeLoop: at phase " ++ show phase ++ - " but I wanted to stop at phase " ++ show stop_phase) - - | otherwise = do - maybe_next_phase <- runPhase phase dflags orig_basename - orig_suff input_fn get_output_fn maybe_loc - case maybe_next_phase of - (Nothing, dflags, maybe_loc, output_fn) -> do - -- we stopped early, but return the *final* filename - -- (it presumably already exists) - final_fn <- get_output_fn stop_phase maybe_loc - return (final_fn, maybe_loc) - (Just next_phase, dflags', maybe_loc, output_fn) -> - pipeLoop dflags' next_phase stop_phase output_fn - orig_basename orig_suff get_output_fn maybe_loc - - -genOutputFilenameFunc :: Bool -> Maybe FilePath -> Phase -> String + = panic ("pipeLoop: at phase " ++ show phase ++ + " but I wanted to stop at phase " ++ show stop_phase) + + | otherwise + = do { (next_phase, dflags', maybe_loc, output_fn) + <- runPhase phase orig_todo dflags orig_basename + orig_suff input_fn orig_get_output_fn maybe_loc + ; pipeLoop orig_todo dflags' next_phase stop_phase output_fn + orig_basename orig_suff orig_get_output_fn maybe_loc } + +genOutputFilenameFunc :: Phase -> Bool -> Maybe FilePath -> String -> IO (Phase{-next phase-} -> Maybe ModLocation -> IO FilePath) -genOutputFilenameFunc keep_final_output maybe_output_filename - stop_phase basename +genOutputFilenameFunc stop_phase keep_final_output maybe_output_filename basename = do hcsuf <- readIORef v_HC_suf odir <- readIORef v_Output_dir @@ -415,9 +444,9 @@ genOutputFilenameFunc keep_final_output maybe_output_filename keep_raw_s <- readIORef v_Keep_raw_s_files keep_s <- readIORef v_Keep_s_files let - myPhaseInputExt HCc | Just s <- hcsuf = s - myPhaseInputExt Ln = osuf - myPhaseInputExt other = phaseInputExt other + myPhaseInputExt HCc = hcsuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other func next_phase maybe_location | is_last_phase, Just f <- maybe_output_filename = return f @@ -426,12 +455,12 @@ genOutputFilenameFunc keep_final_output maybe_output_filename | otherwise = newTempName suffix where - is_last_phase = next_phase == stop_phase + is_last_phase = next_phase `eqPhase` stop_phase -- sometimes, we keep output from intermediate stages keep_this_output = case next_phase of - Ln -> True + StopLn -> True Mangle | keep_raw_s -> True As | keep_s -> True HCc | keep_hc -> True @@ -441,8 +470,8 @@ genOutputFilenameFunc keep_final_output maybe_output_filename -- persistent object files get put in odir persistent_fn - | Ln <- next_phase = return odir_persistent - | otherwise = return persistent + | StopLn <- next_phase = return odir_persistent + | otherwise = return persistent persistent = basename ++ '.':suffix @@ -465,6 +494,7 @@ genOutputFilenameFunc keep_final_output maybe_output_filename -- taking the via-C route to using the native code generator. runPhase :: Phase + -> GhcMode -> DynFlags -> String -- basename of original input source -> String -- its extension @@ -472,18 +502,22 @@ runPhase :: Phase -> (Phase -> Maybe ModLocation -> IO FilePath) -- how to calculate the output filename -> Maybe ModLocation -- the ModLocation, if we have one - -> IO (Maybe Phase, -- next phase + -> IO (Phase, -- next phase DynFlags, -- new dynamic flags Maybe ModLocation, -- the ModLocation, if we have one FilePath) -- output filename + -- Invariant: the output filename always contains the output + -- Interesting case: Hsc when there is no recompilation to do + -- Then the output filename is still a .o file + ------------------------------------------------------------------------------- -- Unlit phase -runPhase Unlit dflags _basename _suff input_fn get_output_fn maybe_loc +runPhase (Unlit sf) _todo dflags _basename _suff input_fn get_output_fn maybe_loc = do let unlit_flags = getOpts dflags opt_L -- The -h option passes the file name for unlit to put in a #line directive - output_fn <- get_output_fn Cpp maybe_loc + output_fn <- get_output_fn (Cpp sf) maybe_loc SysTools.runUnlit dflags (map SysTools.Option unlit_flags ++ @@ -493,12 +527,13 @@ runPhase Unlit dflags _basename _suff input_fn get_output_fn maybe_loc , SysTools.FileOption "" output_fn ]) - return (Just Cpp, dflags, maybe_loc, output_fn) + return (Cpp sf, dflags, maybe_loc, output_fn) ------------------------------------------------------------------------------- --- Cpp phase +-- Cpp phase : (a) gets OPTIONS out of file +-- (b) runs cpp if necessary -runPhase Cpp dflags basename suff input_fn get_output_fn maybe_loc +runPhase (Cpp sf) _todo dflags basename suff input_fn get_output_fn maybe_loc = do src_opts <- getOptionsFromSource input_fn (dflags,unhandled_flags) <- processDynamicFlags src_opts dflags checkProcessArgsResult unhandled_flags (basename++'.':suff) @@ -506,25 +541,25 @@ runPhase Cpp dflags basename suff input_fn get_output_fn maybe_loc if not (cppFlag dflags) then -- no need to preprocess CPP, just pass input file along -- to the next phase of the pipeline. - return (Just HsPp, dflags, maybe_loc, input_fn) + return (HsPp sf, dflags, maybe_loc, input_fn) else do - output_fn <- get_output_fn HsPp maybe_loc + output_fn <- get_output_fn (HsPp sf) maybe_loc doCpp dflags True{-raw-} False{-no CC opts-} input_fn output_fn - return (Just HsPp, dflags, maybe_loc, output_fn) + return (HsPp sf, dflags, maybe_loc, output_fn) ------------------------------------------------------------------------------- -- HsPp phase -runPhase HsPp dflags basename suff input_fn get_output_fn maybe_loc +runPhase (HsPp sf) _todo dflags basename suff input_fn get_output_fn maybe_loc = do if not (ppFlag dflags) then -- no need to preprocess, just pass input file along -- to the next phase of the pipeline. - return (Just Hsc, dflags, maybe_loc, input_fn) + return (Hsc sf, dflags, maybe_loc, input_fn) else do let hspp_opts = getOpts dflags opt_F hs_src_pp_opts <- readIORef v_Hs_source_pp_opts let orig_fn = basename ++ '.':suff - output_fn <- get_output_fn Hsc maybe_loc + output_fn <- get_output_fn (Hsc sf) maybe_loc SysTools.runPp dflags ( [ SysTools.Option orig_fn , SysTools.Option input_fn @@ -533,21 +568,15 @@ runPhase HsPp dflags basename suff input_fn get_output_fn maybe_loc map SysTools.Option hs_src_pp_opts ++ map SysTools.Option hspp_opts ) - return (Just Hsc, dflags, maybe_loc, output_fn) + return (Hsc sf, dflags, maybe_loc, output_fn) ----------------------------------------------------------------------------- -- Hsc phase -- Compilation of a single module, in "legacy" mode (_not_ under -- the direction of the compilation manager). -runPhase Hsc dflags basename suff input_fn get_output_fn _maybe_loc = do - todo <- readIORef v_GhcMode - if todo == DoMkDependHS then do - locn <- doMkDependHSPhase dflags basename suff input_fn - return (Nothing, dflags, Just locn, input_fn) -- Ln is a dummy stop phase - - else do - -- normal Hsc mode, not mkdependHS +runPhase (Hsc src_flavour) todo dflags basename suff input_fn get_output_fn _maybe_loc + = do -- normal Hsc mode, not mkdependHS -- we add the current directory (i.e. the directory in which -- the .hs files resides) to the import path, since this is @@ -559,25 +588,67 @@ runPhase Hsc dflags basename suff input_fn get_output_fn _maybe_loc = do -- gather the imports and module name (hspp_buf,mod_name) <- - if isExtCoreFilename ('.':suff) - then do - -- no explicit imports in ExtCore input. - m <- getCoreModuleName input_fn - return (Nothing, mkModule m) - else do - buf <- hGetStringBuffer input_fn - (_,_,mod_name) <- getImports dflags buf input_fn - return (Just buf, mod_name) - - -- build a ModLocation to pass to hscMain. - location' <- mkHomeModLocation mod_name (basename ++ '.':suff) - - -- take -ohi into account if present + case src_flavour of + ExtCoreFile -> do { -- no explicit imports in ExtCore input. + ; m <- getCoreModuleName input_fn + ; return (Nothing, mkModule m) } + + other -> do { buf <- hGetStringBuffer input_fn + ; (_,_,mod_name) <- getImports dflags buf input_fn + ; return (Just buf, mod_name) } + + -- Build a ModLocation to pass to hscMain. + -- The source filename is rather irrelevant by now, but it's used + -- by hscMain for messages. hscMain also needs + -- the .hi and .o filenames, and this is as good a way + -- as any to generate them, and better than most. (e.g. takes + -- into accout the -osuf flags) + location1 <- mkHomeModLocation2 mod_name basename suff + + -- Boot-ify it if necessary + let location2 | isHsBoot src_flavour = addBootSuffixLocn location1 + | otherwise = location1 + + + -- Take -ohi into account if present + -- This can't be done in mkHomeModuleLocation because + -- it only applies to the module being compiles ohi <- readIORef v_Output_hi - let location | Just fn <- ohi = location'{ ml_hi_file = fn } - | otherwise = location' - - -- figure out if the source has changed, for recompilation avoidance. + let location3 | Just fn <- ohi = location2{ ml_hi_file = fn } + | otherwise = location2 + + -- Take -o into account if present + -- Very like -ohi, but we must *only* do this if we aren't linking + -- (If we're linking then the -o applies to the linked thing, not to + -- the object file for one module.) + -- Note the nasty duplication with the same computation in compileFile above + expl_o_file <- readIORef v_Output_file + no_link <- readIORef v_NoLink + let location4 | Just ofile <- expl_o_file, no_link + = location3 { ml_obj_file = ofile } + | otherwise = location3 + + -- Tell the finder cache about this module + addHomeModuleToFinder mod_name location4 + + -- Make the ModSummary to hand to hscMain + src_timestamp <- getModificationTime (basename ++ '.':suff) + let + unused_field = panic "runPhase:ModSummary field" + -- Some fields are not looked at by hscMain + mod_summary = ModSummary { ms_mod = mod_name, + ms_hsc_src = src_flavour, + ms_hspp_file = Just input_fn, + ms_hspp_buf = hspp_buf, + ms_location = location4, + ms_hs_date = src_timestamp, + ms_imps = unused_field, + ms_srcimps = unused_field } + + o_file = ml_obj_file location4 -- The real object file + + + -- Figure out if the source has changed, for recompilation avoidance. -- only do this if we're eventually going to generate a .o file. -- (ToDo: do when generating .hc files too?) -- @@ -586,46 +657,36 @@ runPhase Hsc dflags basename suff input_fn get_output_fn _maybe_loc = do -- changed (which the compiler itself figures out). -- Setting source_unchanged to False tells the compiler that M.o is out of -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. - do_recomp <- readIORef v_Recomp - expl_o_file <- readIORef v_Output_file - - let o_file -- if the -o option is given and IT IS THE OBJECT FILE FOR - -- THIS COMPILATION, then use that to determine if the - -- source is unchanged. - | Just x <- expl_o_file, todo == StopBefore Ln = x - | otherwise = ml_obj_file location - + do_recomp <- readIORef v_Recomp source_unchanged <- - if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln )) + if not (do_recomp && case todo of { DoLink -> True; other -> False }) then return False - else do t1 <- getModificationTime (basename ++ '.':suff) - o_file_exists <- doesFileExist o_file + else do o_file_exists <- doesFileExist o_file if not o_file_exists then return False -- Need to recompile else do t2 <- getModificationTime o_file - if t2 > t1 + if t2 > src_timestamp then return True else return False -- get the DynFlags - hsc_lang <- hscMaybeAdjustLang (hscLang dflags) - next_phase <- hscNextPhase hsc_lang - output_fn <- get_output_fn next_phase (Just location) + hsc_lang <- hscMaybeAdjustTarget todo src_flavour (hscTarget dflags) + next_phase <- hscNextPhase src_flavour hsc_lang + output_fn <- get_output_fn next_phase (Just location4) - let dflags' = dflags { hscLang = hsc_lang, + let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, hscStubCOutName = basename ++ "_stub.c", hscStubHOutName = basename ++ "_stub.h", extCoreName = basename ++ ".hcr" } + hsc_env <- newHscEnv OneShot dflags' -- run the compiler! - result <- hscMain hsc_env printErrorsAndWarnings mod_name - location{ ml_hspp_file = Just input_fn, - ml_hspp_buf = hspp_buf } - source_unchanged - False - Nothing -- no iface + result <- hscMain hsc_env printErrorsAndWarnings + mod_summary source_unchanged + False -- No object file + Nothing -- No iface case result of @@ -633,37 +694,42 @@ runPhase Hsc dflags basename suff input_fn get_output_fn _maybe_loc = do HscNoRecomp details iface -> do SysTools.touch dflags' "Touching object file" o_file - return (Nothing, dflags', Just location, output_fn) + return (StopLn, dflags', Just location4, o_file) HscRecomp _details _rdr_env _iface stub_h_exists stub_c_exists _maybe_interpreted_code -> do - -- deal with stubs + -- Deal with stubs maybe_stub_o <- compileStub dflags' stub_c_exists case maybe_stub_o of - Nothing -> return () + Nothing -> return () Just stub_o -> add v_Ld_inputs stub_o - case hscLang dflags' of - HscNothing -> return (Nothing, dflags', Just location, output_fn) - _ -> return (Just next_phase, dflags', Just location, output_fn) + + -- In the case of hs-boot files, generate a dummy .o-boot + -- stamp file for the benefit of Make + case src_flavour of + HsBootFile -> SysTools.touch dflags' "Touching object file" o_file + other -> return () + + return (next_phase, dflags', Just location4, output_fn) ----------------------------------------------------------------------------- -- Cmm phase -runPhase CmmCpp dflags basename suff input_fn get_output_fn maybe_loc +runPhase CmmCpp todo dflags basename suff input_fn get_output_fn maybe_loc = do output_fn <- get_output_fn Cmm maybe_loc doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn - return (Just Cmm, dflags, maybe_loc, output_fn) + return (Cmm, dflags, maybe_loc, output_fn) -runPhase Cmm dflags basename suff input_fn get_output_fn maybe_loc +runPhase Cmm todo dflags basename suff input_fn get_output_fn maybe_loc = do - hsc_lang <- hscMaybeAdjustLang (hscLang dflags) - next_phase <- hscNextPhase hsc_lang + hsc_lang <- hscMaybeAdjustTarget todo HsSrcFile (hscTarget dflags) + next_phase <- hscNextPhase HsSrcFile hsc_lang output_fn <- get_output_fn next_phase maybe_loc - let dflags' = dflags { hscLang = hsc_lang, + let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, hscStubCOutName = basename ++ "_stub.c", hscStubHOutName = basename ++ "_stub.h", @@ -673,7 +739,7 @@ runPhase Cmm dflags basename suff input_fn get_output_fn maybe_loc when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1)) - return (Just next_phase, dflags, maybe_loc, output_fn) + return (next_phase, dflags, maybe_loc, output_fn) ----------------------------------------------------------------------------- -- Cc phase @@ -681,21 +747,12 @@ runPhase Cmm dflags basename suff input_fn get_output_fn maybe_loc -- we don't support preprocessing .c files (with -E) now. Doing so introduces -- way too many hacks, and I can't say I've ever used it anyway. -runPhase cc_phase dflags basename suff input_fn get_output_fn maybe_loc - | cc_phase == Cc || cc_phase == HCc +runPhase cc_phase todo dflags basename suff input_fn get_output_fn maybe_loc + | cc_phase `eqPhase` Cc || cc_phase `eqPhase` HCc = do let cc_opts = getOpts dflags opt_c - cmdline_include_paths <- readIORef v_Include_paths - - split <- readIORef v_Split_object_files - mangle <- readIORef v_Do_asm_mangling + hcc = cc_phase `eqPhase` HCc - let hcc = cc_phase == HCc - - next_phase - | hcc && mangle = Mangle - | otherwise = As - - output_fn <- get_output_fn next_phase maybe_loc + cmdline_include_paths <- readIORef v_Include_paths -- HC files have the dependent packages stamped into them pkgs <- if hcc then getHCFilePackages input_fn else return [] @@ -707,7 +764,6 @@ runPhase cc_phase dflags basename suff input_fn get_output_fn maybe_loc let include_paths = foldr (\ x xs -> "-I" : x : xs) [] (cmdline_include_paths ++ pkg_include_dirs) - mangle <- readIORef v_Do_asm_mangling (md_c_flags, md_regd_c_flags) <- machdepCCOpts dflags let verb = getVerbFlag dflags @@ -720,11 +776,17 @@ runPhase cc_phase dflags basename suff input_fn get_output_fn maybe_loc excessPrecision <- readIORef v_Excess_precision + -- Decide next phase + mangle <- readIORef v_Do_asm_mangling + let next_phase + | hcc && mangle = Mangle + | otherwise = As + output_fn <- get_output_fn next_phase maybe_loc + -- force the C compiler to interpret this file as C when -- compiling .hc files, by adding the -x c option. - let langopt - | cc_phase == HCc = [ SysTools.Option "-x", SysTools.Option "c"] - | otherwise = [ ] + let langopt | hcc = [ SysTools.Option "-x", SysTools.Option "c"] + | otherwise = [ ] SysTools.runCc dflags (langopt ++ [ SysTools.FileOption "" input_fn @@ -733,7 +795,7 @@ runPhase cc_phase dflags basename suff input_fn get_output_fn maybe_loc ] ++ map SysTools.Option ( md_c_flags - ++ (if cc_phase == HCc && mangle + ++ (if hcc && mangle then md_regd_c_flags else []) ++ [ verb, "-S", "-Wimplicit", "-O" ] @@ -745,14 +807,14 @@ runPhase cc_phase dflags basename suff input_fn get_output_fn maybe_loc ++ pkg_extra_cc_opts )) - return (Just next_phase, dflags, maybe_loc, output_fn) + return (next_phase, dflags, maybe_loc, output_fn) -- ToDo: postprocess the output from gcc ----------------------------------------------------------------------------- -- Mangle phase -runPhase Mangle dflags _basename _suff input_fn get_output_fn maybe_loc +runPhase Mangle todo dflags _basename _suff input_fn get_output_fn maybe_loc = do let mangler_opts = getOpts dflags opt_m machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM) then do let n_regs = stolen_x86_regs dflags @@ -771,12 +833,12 @@ runPhase Mangle dflags _basename _suff input_fn get_output_fn maybe_loc ] ++ map SysTools.Option machdep_opts) - return (Just next_phase, dflags, maybe_loc, output_fn) + return (next_phase, dflags, maybe_loc, output_fn) ----------------------------------------------------------------------------- -- Splitting phase -runPhase SplitMangle dflags _basename _suff input_fn get_output_fn maybe_loc +runPhase SplitMangle todo dflags _basename _suff input_fn get_output_fn maybe_loc = do -- tmp_pfx is the prefix used for the split .s files -- We also use it as the file to contain the no. of split .s files (sigh) split_s_prefix <- SysTools.newTempName "split" @@ -797,17 +859,17 @@ runPhase SplitMangle dflags _basename _suff input_fn get_output_fn maybe_loc addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s" | n <- [1..n_files]] - return (Just SplitAs, dflags, maybe_loc, "**splitmangle**") + return (SplitAs, dflags, maybe_loc, "**splitmangle**") -- we don't use the filename ----------------------------------------------------------------------------- -- As phase -runPhase As dflags _basename _suff input_fn get_output_fn maybe_loc +runPhase As todo dflags _basename _suff input_fn get_output_fn maybe_loc = do let as_opts = getOpts dflags opt_a cmdline_include_paths <- readIORef v_Include_paths - output_fn <- get_output_fn Ln maybe_loc + output_fn <- get_output_fn StopLn maybe_loc -- we create directories for the object file, because it -- might be a hierarchical module. @@ -822,10 +884,10 @@ runPhase As dflags _basename _suff input_fn get_output_fn maybe_loc , SysTools.FileOption "" output_fn ]) - return (Just Ln, dflags, maybe_loc, output_fn) + return (StopLn, dflags, maybe_loc, output_fn) -runPhase SplitAs dflags basename _suff _input_fn get_output_fn maybe_loc +runPhase SplitAs todo dflags basename _suff _input_fn get_output_fn maybe_loc = do let as_opts = getOpts dflags opt_a (split_s_prefix, n) <- readIORef v_Split_info @@ -851,15 +913,15 @@ runPhase SplitAs dflags basename _suff _input_fn get_output_fn maybe_loc mapM_ assemble_file [1..n] - output_fn <- get_output_fn Ln maybe_loc - return (Just Ln, dflags, maybe_loc, output_fn) + output_fn <- get_output_fn StopLn maybe_loc + return (StopLn, dflags, maybe_loc, output_fn) #ifdef ILX ----------------------------------------------------------------------------- -- Ilx2Il phase -- Run ilx2il over the ILX output, getting an IL file -runPhase Ilx2Il dflags _basename _suff input_fn get_output_fn maybe_loc +runPhase Ilx2Il todo dflags _basename _suff input_fn get_output_fn maybe_loc = do let ilx2il_opts = getOpts dflags opt_I SysTools.runIlx2il (map SysTools.Option ilx2il_opts ++ [ SysTools.Option "--no-add-suffix-to-assembly", @@ -873,7 +935,7 @@ runPhase Ilx2Il dflags _basename _suff input_fn get_output_fn maybe_loc -- Ilasm phase -- Run ilasm over the IL, getting a DLL -runPhase Ilasm dflags _basename _suff input_fn get_output_fn maybe_loc +runPhase Ilasm todo dflags _basename _suff input_fn get_output_fn maybe_loc = do let ilasm_opts = getOpts dflags opt_i SysTools.runIlasm (map SysTools.Option ilasm_opts ++ [ SysTools.Option "/QUIET", @@ -1038,7 +1100,6 @@ staticLink dflags o_files dep_packages = do pkg_frameworks <- getPackageFrameworks dflags dep_packages let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ] - frameworks <- readIORef v_Cmdline_frameworks let framework_opts = concat [ ["-framework", fw] | fw <- reverse frameworks ] -- reverse because they're added in reverse order from the cmd line @@ -1050,14 +1111,6 @@ staticLink dflags o_files dep_packages = do -- opts from -optl- (including -l options) extra_ld_opts <- getStaticOpts v_Opt_l - let pstate = pkgState dflags - rts_id | ExtPackage id <- rtsPackageId pstate = id - | otherwise = panic "staticLink: rts package missing" - base_id | ExtPackage id <- basePackageId pstate = id - | otherwise = panic "staticLink: base package missing" - rts_pkg = getPackageDetails pstate rts_id - base_pkg = getPackageDetails pstate base_id - ways <- readIORef v_Ways -- Here are some libs that need to be linked at the *end* of @@ -1082,10 +1135,6 @@ staticLink dflags o_files dep_packages = do ] | otherwise = [] - let extra_os = if static || no_hs_main - then [] - else [] - (md_c_flags, _) <- machdepCCOpts dflags SysTools.runLink dflags ( [ SysTools.Option verb @@ -1095,7 +1144,6 @@ staticLink dflags o_files dep_packages = do ++ map SysTools.Option ( md_c_flags ++ o_files - ++ extra_os ++ extra_ld_inputs ++ lib_path_opts ++ extra_ld_opts @@ -1232,27 +1280,33 @@ doCpp dflags raw include_cc_opts input_fn output_fn = do -- ----------------------------------------------------------------------------- -- Misc. -hscNextPhase :: HscLang -> IO Phase -hscNextPhase hsc_lang = do +hscNextPhase :: HscSource -> HscTarget -> IO Phase +hscNextPhase HsBootFile hsc_lang + = return StopLn + +hscNextPhase other hsc_lang = do split <- readIORef v_Split_object_files return (case hsc_lang of HscC -> HCc HscAsm | split -> SplitMangle | otherwise -> As - HscNothing -> HCc -- dummy (no output will be generated) - HscInterpreted -> HCc -- "" "" - _other -> HCc -- "" "" + HscNothing -> StopLn + HscInterpreted -> StopLn + _other -> StopLn ) -hscMaybeAdjustLang :: HscLang -> IO HscLang -hscMaybeAdjustLang current_hsc_lang = do - todo <- readIORef v_GhcMode - keep_hc <- readIORef v_Keep_hc_files - let hsc_lang - -- don't change the lang if we're interpreting - | current_hsc_lang == HscInterpreted = current_hsc_lang - -- force -fvia-C if we are being asked for a .hc file - | todo == StopBefore HCc || keep_hc = HscC - -- otherwise, stick to the plan - | otherwise = current_hsc_lang - return hsc_lang +hscMaybeAdjustTarget :: GhcMode -> HscSource -> HscTarget -> IO HscTarget +hscMaybeAdjustTarget todo HsBootFile current_hsc_lang + = return HscNothing -- No output (other than Foo.hi-boot) for hs-boot files +hscMaybeAdjustTarget todo other current_hsc_lang + = do { keep_hc <- readIORef v_Keep_hc_files + ; let hsc_lang + -- don't change the lang if we're interpreting + | current_hsc_lang == HscInterpreted = current_hsc_lang + + -- force -fvia-C if we are being asked for a .hc file + | StopBefore HCc <- todo = HscC + | keep_hc = HscC + -- otherwise, stick to the plan + | otherwise = current_hsc_lang + ; return hsc_lang } diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index cb8e6a9..c70d16b 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -43,7 +43,7 @@ data GhcMode | DoInteractive -- ghc --interactive | DoLink -- [ the default ] | DoEval String -- ghc -e - deriving (Eq,Show) + deriving (Show) GLOBAL_VAR(v_GhcMode, DoLink, GhcMode) GLOBAL_VAR(v_GhcModeFlag, "", String) @@ -58,6 +58,24 @@ setMode m flag = do writeIORef v_GhcMode m writeIORef v_GhcModeFlag flag +isInteractiveMode, isInterpretiveMode :: GhcMode -> Bool +isMakeMode, isLinkMode, isCompManagerMode :: GhcMode -> Bool + +isInteractiveMode DoInteractive = True +isInteractiveMode _ = False + +-- isInterpretiveMode: byte-code compiler involved +isInterpretiveMode DoInteractive = True +isInterpretiveMode (DoEval _) = True +isInterpretiveMode _ = False + +isMakeMode DoMake = True +isMakeMode _ = False + +isLinkMode DoLink = True +isLinkMode DoMkDLL = True +isLinkMode _ = False + isCompManagerMode DoMake = True isCompManagerMode DoInteractive = True isCompManagerMode (DoEval _) = True @@ -157,8 +175,8 @@ verifyOutputFiles = do show dir ++ " does not exist (used with " ++ show flg ++ " option.)")) -GLOBAL_VAR(v_Object_suf, phaseInputExt Ln, String) -GLOBAL_VAR(v_HC_suf, Nothing, Maybe String) +GLOBAL_VAR(v_Object_suf, phaseInputExt StopLn, String) +GLOBAL_VAR(v_HC_suf, phaseInputExt HCc, String) GLOBAL_VAR(v_Hi_dir, Nothing, Maybe String) GLOBAL_VAR(v_Hi_suf, "hi", String) diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index edae27e..6173853 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -7,15 +7,15 @@ module Finder ( flushFinderCache, -- :: IO () FindResult(..), - findModule, -- :: ModuleName -> Bool -> IO FindResult - findPackageModule, -- :: ModuleName -> Bool -> IO FindResult - mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation - findLinkable, -- :: ModuleName -> ModLocation -> IO (Maybe Linkable) + findModule, -- :: ModuleName -> Bool -> IO FindResult + findPackageModule, -- :: ModuleName -> Bool -> IO FindResult + mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation + mkHomeModLocation2, -- :: ModuleName -> FilePath -> String -> IO ModLocation + addHomeModuleToFinder, -- :: Module -> ModLocation -> IO () - hiBootFilePath, -- :: ModLocation -> IO FilePath - hiBootExt, -- :: String - hiBootVerExt, -- :: String + findLinkable, -- :: ModuleName -> ModLocation -> IO (Maybe Linkable) + cantFindError, -- :: DynFlags -> Module -> FindResult -> SDoc ) where #include "HsVersions.h" @@ -27,9 +27,9 @@ import Packages import DriverState import DriverUtil import FastString -import Config import Util import CmdLineOpts ( DynFlags(..) ) +import Outputable import DATA_IOREF ( IORef, writeIORef, readIORef ) @@ -37,8 +37,13 @@ import Data.List import System.Directory import System.IO import Control.Monad +import Maybes ( MaybeErr(..) ) import Data.Maybe ( isNothing ) + +type FileExt = String -- Filename extension +type BaseName = String -- Basename of file + -- ----------------------------------------------------------------------------- -- The Finder @@ -54,7 +59,7 @@ import Data.Maybe ( isNothing ) GLOBAL_VAR(finder_cache, emptyModuleEnv, ModuleEnv FinderCacheEntry) -type FinderCacheEntry = (ModLocation,Maybe (PackageConfig,Bool)) +type FinderCacheEntry = (ModLocation, Maybe (PackageConfig,Bool)) -- remove all the home modules from the cache; package modules are -- assumed to not move around during a session. @@ -98,137 +103,130 @@ data FindResult | NotFound [FilePath] -- the module was not found, the specified places were searched. +type LocalFindResult = MaybeErr [FilePath] FinderCacheEntry + -- LocalFindResult is used for internal functions which + -- return a more informative type; it's munged into + -- the external FindResult by 'cached' + +cached :: (DynFlags -> Module -> IO LocalFindResult) + -> DynFlags -> Module -> Bool -> IO FindResult +cached wrapped_fn dflags name explicit + = do { -- First try the cache + mb_entry <- lookupFinderCache name + ; case mb_entry of { + Just old_entry -> return (found old_entry) ; + Nothing -> do + + { -- Now try the wrapped function + mb_entry <- wrapped_fn dflags name + ; case mb_entry of + Failed paths -> return (NotFound paths) + Succeeded new_entry -> do { addToFinderCache name new_entry + ; return (found new_entry) } + }}} + where + -- We've found the module, so the remaining question is + -- whether it's visible or not + found :: FinderCacheEntry -> FindResult + found (loc, Nothing) = Found loc HomePackage + found (loc, Just (pkg, exposed_mod)) + | explicit && not exposed_mod = ModuleHidden pkg_name + | explicit && not (exposed pkg) = PackageHidden pkg_name + | otherwise = Found loc (ExtPackage (mkPackageId (package pkg))) + where + pkg_name = packageConfigId pkg + +addHomeModuleToFinder :: Module -> ModLocation -> IO () +addHomeModuleToFinder mod loc = addToFinderCache mod (loc, Nothing) + + +-- ----------------------------------------------------------------------------- +-- The two external entry points + + findModule :: DynFlags -> Module -> Bool -> IO FindResult -findModule = cached findModule' +findModule = cached findModule' -findModule' :: DynFlags -> Module -> Bool -> IO FindResult -findModule' dflags name explicit = do - r <- findPackageModule' dflags name explicit +findPackageModule :: DynFlags -> Module -> Bool -> IO FindResult +findPackageModule = cached findPackageModule' + +-- ----------------------------------------------------------------------------- +-- The internal workers + +findModule' :: DynFlags -> Module -> IO LocalFindResult +-- Find home or package module +findModule' dflags name = do + r <- findPackageModule' dflags name case r of - NotFound pkg_files -> do - j <- maybeHomeModule dflags name + Failed pkg_files -> do + j <- findHomeModule' dflags name case j of - NotFound home_files -> - return (NotFound (home_files ++ pkg_files)) + Failed home_files -> + return (Failed (home_files ++ pkg_files)) other_result -> return other_result other_result -> return other_result -cached fn dflags name explicit = do - m <- lookupFinderCache name - case m of - Nothing -> fn dflags name explicit - Just (loc,maybe_pkg) - | Just err <- visible explicit maybe_pkg -> return err - | otherwise -> return (Found loc (pkgInfoToId maybe_pkg)) - -pkgInfoToId :: Maybe (PackageConfig,Bool) -> PackageIdH -pkgInfoToId (Just (pkg,_)) = ExtPackage (mkPackageId (package pkg)) -pkgInfoToId Nothing = HomePackage - --- Is a module visible or not? Returns Nothing if the import is ok, --- or Just err if there's a visibility error. -visible :: Bool -> Maybe (PackageConfig,Bool) -> Maybe FindResult -visible explicit maybe_pkg - | Nothing <- maybe_pkg = Nothing -- home module ==> YES - | not explicit = Nothing -- implicit import ==> YES - | Just (pkg, exposed_module) <- maybe_pkg - = case () of - _ | not exposed_module -> Just (ModuleHidden pkgname) - | not (exposed pkg) -> Just (PackageHidden pkgname) - | otherwise -> Nothing - where - pkgname = packageConfigId pkg - - -hiBootExt = "hi-boot" -hiBootVerExt = "hi-boot-" ++ cHscIfaceFileVersion - -maybeHomeModule :: DynFlags -> Module -> IO FindResult -maybeHomeModule dflags mod = do +findHomeModule' :: DynFlags -> Module -> IO LocalFindResult +findHomeModule' dflags mod = do let home_path = importPaths dflags hisuf <- readIORef v_Hi_suf mode <- readIORef v_GhcMode let source_exts = - [ ("hs", mkHomeModLocationSearched mod) - , ("lhs", mkHomeModLocationSearched mod) + [ ("hs", mkHomeModLocationSearched mod "hs") + , ("lhs", mkHomeModLocationSearched mod "lhs") ] - hi_exts = [ (hisuf, mkHiOnlyModLocation hisuf mod) ] + hi_exts = [ (hisuf, mkHiOnlyModLocation hisuf) + , (addBootSuffix hisuf, mkHiOnlyModLocation hisuf) + ] - boot_exts = - [ (hiBootVerExt, mkHiOnlyModLocation hisuf mod) - , (hiBootExt, mkHiOnlyModLocation hisuf mod) - ] - -- In compilation manager modes, we look for source files in the home -- package because we can compile these automatically. In one-shot -- compilation mode we look for .hi and .hi-boot files only. - -- - -- When generating dependencies, we're interested in either category. - -- exts - | mode == DoMkDependHS = hi_exts ++ source_exts ++ boot_exts + | DoMkDependHS <- mode = source_exts | isCompManagerMode mode = source_exts - | otherwise {-one-shot-} = hi_exts ++ boot_exts + | otherwise {-one-shot-} = hi_exts searchPathExts home_path mod exts --- ----------------------------------------------------------------------------- --- Looking for a package module - -findPackageModule :: DynFlags -> Module -> Bool -> IO FindResult -findPackageModule = cached findPackageModule' - -findPackageModule' :: DynFlags -> Module -> Bool -> IO FindResult -findPackageModule' dflags mod explicit = do - mode <- readIORef v_GhcMode - - case moduleToPackageConfig dflags mod of - Nothing -> return (NotFound []) - pkg_info@(Just (pkg_conf, module_exposed)) - | Just err <- visible explicit pkg_info -> return err - | otherwise -> findPackageIface mode mod paths pkg_info - where - paths = importDirs pkg_conf - -findPackageIface - :: GhcMode - -> Module - -> [FilePath] - -> Maybe (PackageConfig,Bool) - -> IO FindResult -findPackageIface mode mod imp_dirs pkg_info = do - -- hi-suffix for packages depends on the build tag. - package_hisuf <- - do tag <- readIORef v_Build_tag - if null tag - then return "hi" - else return (tag ++ "_hi") - +findPackageModule' :: DynFlags -> Module -> IO LocalFindResult +findPackageModule' dflags mod + = case moduleToPackageConfig dflags mod of + Nothing -> return (Failed []) + Just pkg_info -> findPackageIface mod pkg_info + +findPackageIface :: Module -> (PackageConfig,Bool) -> IO LocalFindResult +findPackageIface mod pkg_info@(pkg_conf, _) = do + mode <- readIORef v_GhcMode + tag <- readIORef v_Build_tag let + -- hi-suffix for packages depends on the build tag. + package_hisuf | null tag = "hi" + | otherwise = tag ++ "_hi" hi_exts = [ (package_hisuf, - mkPackageModLocation pkg_info package_hisuf mod) ] + mkPackageModLocation pkg_info package_hisuf) ] source_exts = - [ ("hs", mkPackageModLocation pkg_info package_hisuf mod) - , ("lhs", mkPackageModLocation pkg_info package_hisuf mod) + [ ("hs", mkPackageModLocation pkg_info package_hisuf) + , ("lhs", mkPackageModLocation pkg_info package_hisuf) ] -- mkdependHS needs to look for source files in packages too, so -- that we can make dependencies between package before they have -- been built. exts - | mode == DoMkDependHS = hi_exts ++ source_exts - | otherwise = hi_exts - + | DoMkDependHS <- mode = hi_exts ++ source_exts + | otherwise = hi_exts -- we never look for a .hi-boot file in an external package; -- .hi-boot files only make sense for the home package. - searchPathExts imp_dirs mod exts + + searchPathExts (importDirs pkg_conf) mod exts -- ----------------------------------------------------------------------------- -- General path searching @@ -237,60 +235,59 @@ searchPathExts :: [FilePath] -- paths to search -> Module -- module name -> [ ( - String, -- suffix - String -> String -> String -> IO FindResult -- action + FileExt, -- suffix + FilePath -> BaseName -> IO FinderCacheEntry -- action ) ] - -> IO FindResult + -> IO LocalFindResult + +searchPathExts paths mod exts + = do result <- search to_search +{- + hPutStrLn stderr (showSDoc $ + vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) + , nest 2 (vcat (map text paths)) + , case result of + Succeeded (loc, p) -> text "Found" <+> ppr loc + Failed fs -> text "not found"]) +-} + return result -searchPathExts path mod exts = search to_search where basename = dots_to_slashes (moduleUserString mod) - to_search :: [(FilePath, IO FindResult)] - to_search = [ (file, fn p basename ext) - | p <- path, + to_search :: [(FilePath, IO FinderCacheEntry)] + to_search = [ (file, fn path basename) + | path <- paths, (ext,fn) <- exts, - let base | p == "." = basename - | otherwise = p ++ '/':basename + let base | path == "." = basename + | otherwise = path ++ '/':basename file = base ++ '.':ext ] - search [] = return (NotFound (map fst to_search)) - search ((file, result) : rest) = do + search [] = return (Failed (map fst to_search)) + search ((file, mk_result) : rest) = do b <- doesFileExist file if b - then result + then do { res <- mk_result; return (Succeeded res) } else search rest --- ----------------------------------------------------------------------------- --- Building ModLocations +mkHomeModLocationSearched :: Module -> FileExt + -> FilePath -> BaseName -> IO FinderCacheEntry +mkHomeModLocationSearched mod suff path basename = do + loc <- mkHomeModLocation2 mod (path ++ '/':basename) suff + return (loc, Nothing) -mkHiOnlyModLocation hisuf mod path basename _ext = do - -- basename == dots_to_slashes (moduleNameUserString mod) +mkHiOnlyModLocation :: FileExt -> FilePath -> BaseName -> IO FinderCacheEntry +mkHiOnlyModLocation hisuf path basename = do loc <- hiOnlyModLocation path basename hisuf - addToFinderCache mod (loc, Nothing) - return (Found loc HomePackage) + return (loc, Nothing) -mkPackageModLocation pkg_info hisuf mod path basename _ext = do - -- basename == dots_to_slashes (moduleNameUserString mod) +mkPackageModLocation :: (PackageConfig, Bool) -> FileExt + -> FilePath -> BaseName -> IO FinderCacheEntry +mkPackageModLocation pkg_info hisuf path basename = do loc <- hiOnlyModLocation path basename hisuf - addToFinderCache mod (loc, pkg_info) - return (Found loc (pkgInfoToId pkg_info)) - -hiOnlyModLocation path basename hisuf - = do let full_basename = path++'/':basename - obj_fn <- mkObjPath full_basename basename - return ModLocation{ ml_hspp_file = Nothing, - ml_hspp_buf = Nothing, - ml_hs_file = Nothing, - ml_hi_file = full_basename ++ '.':hisuf, - -- Remove the .hi-boot suffix from - -- hi_file, if it had one. We always - -- want the name of the real .hi file - -- in the ml_hi_file field. - ml_obj_file = obj_fn - } + return (loc, Just pkg_info) -- ----------------------------------------------------------------------------- -- Constructing a home module location @@ -325,28 +322,37 @@ hiOnlyModLocation path basename hisuf -- ext -- The filename extension of the source file (usually "hs" or "lhs"). +mkHomeModLocation :: Module -> FilePath -> IO ModLocation mkHomeModLocation mod src_filename = do let (basename,extension) = splitFilename src_filename - mkHomeModLocation' mod basename extension + mkHomeModLocation2 mod basename extension -mkHomeModLocationSearched mod path basename ext = do - loc <- mkHomeModLocation' mod (path ++ '/':basename) ext - return (Found loc HomePackage) - -mkHomeModLocation' mod src_basename ext = do +mkHomeModLocation2 :: Module + -> FilePath -- Of source module, without suffix + -> String -- Suffix + -> IO ModLocation +mkHomeModLocation2 mod src_basename ext = do let mod_basename = dots_to_slashes (moduleUserString mod) obj_fn <- mkObjPath src_basename mod_basename hi_fn <- mkHiPath src_basename mod_basename - let loc = ModLocation{ ml_hspp_file = Nothing, - ml_hspp_buf = Nothing, - ml_hs_file = Just (src_basename ++ '.':ext), - ml_hi_file = hi_fn, - ml_obj_file = obj_fn } + return (ModLocation{ ml_hs_file = Just (src_basename ++ '.':ext), + ml_hi_file = hi_fn, + ml_obj_file = obj_fn }) - addToFinderCache mod (loc, Nothing) - return loc +hiOnlyModLocation :: FilePath -> String -> Suffix -> IO ModLocation +hiOnlyModLocation path basename hisuf + = do let full_basename = path++'/':basename + obj_fn <- mkObjPath full_basename basename + return ModLocation{ ml_hs_file = Nothing, + ml_hi_file = full_basename ++ '.':hisuf, + -- Remove the .hi-boot suffix from + -- hi_file, if it had one. We always + -- want the name of the real .hi file + -- in the ml_hi_file field. + ml_obj_file = obj_fn + } -- | Constructs the filename of a .o file for a given source file. -- Does /not/ check whether the .o file exists @@ -379,18 +385,6 @@ mkHiPath basename mod_basename return (hi_basename ++ '.':hisuf) --------------------- -hiBootFilePath :: ModLocation -> IO FilePath --- Return Foo.hi-boot, or Foo.hi-boot-n, as appropriate -hiBootFilePath (ModLocation { ml_hi_file = hi_path }) - = do { hi_ver_exists <- doesFileExist hi_boot_ver_path - ; if hi_ver_exists then return hi_boot_ver_path - else return hi_boot_path } - where - hi_boot_path = replaceFilenameSuffix hi_path hiBootExt ; - hi_boot_ver_path = replaceFilenameSuffix hi_path hiBootVerExt - - -- ----------------------------------------------------------------------------- -- findLinkable isn't related to the other stuff in here, -- but there's no other obvious place for it @@ -415,4 +409,31 @@ findLinkable mod locn dots_to_slashes = map (\c -> if c == '.' then '/' else c) + +-- ----------------------------------------------------------------------------- +-- Error messages + +cantFindError :: DynFlags -> Module -> FindResult -> SDoc +cantFindError dflags mod_name find_result + = hang (ptext SLIT("Could not find module") <+> quotes (ppr mod_name) <> colon) + 2 more_info + where + more_info + = case find_result of + PackageHidden pkg + -> ptext SLIT("it is a member of package") <+> ppr pkg <> comma + <+> ptext SLIT("which is hidden") + + ModuleHidden pkg + -> ptext SLIT("it is hidden") <+> parens (ptext SLIT("in package") + <+> ppr pkg) + + NotFound files + | verbosity dflags < 3 + -> ptext SLIT("use -v to see a list of the files searched for") + | otherwise + -> hang (ptext SLIT("locations searched:")) + 2 (vcat (map text files)) + + Found _ _ -> panic "cantFindErr" \end{code} diff --git a/ghc/compiler/main/GetImports.hs b/ghc/compiler/main/GetImports.hs index e60cb25..6c9f9ef 100644 --- a/ghc/compiler/main/GetImports.hs +++ b/ghc/compiler/main/GetImports.hs @@ -15,6 +15,7 @@ import Parser ( parseHeader ) import Lexer ( P(..), ParseResult(..), mkPState ) import HsSyn ( ImportDecl(..), HsModule(..) ) import Module ( Module, mkModule ) +import PrelNames ( gHC_PRIM ) import StringBuffer ( StringBuffer, hGetStringBuffer ) import SrcLoc ( Located(..), mkSrcLoc, unLoc ) import FastString ( mkFastString ) @@ -49,7 +50,8 @@ getImports dflags buf filename = do | otherwise = mkModule "Main" (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps) source_imps = map getImpMod src_idecls - ordinary_imps = map getImpMod ord_idecls + ordinary_imps = filter (/= gHC_PRIM) (map getImpMod ord_idecls) + -- GHC.Prim doesn't exist physically, so don't go looking for it. in return (source_imps, ordinary_imps, mod_name) diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index ec550fa..ab5916d 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -21,6 +21,7 @@ module HscMain ( #ifdef GHCI import HsSyn ( Stmt(..), LStmt, LHsExpr, LHsType ) import IfaceSyn ( IfaceDecl, IfaceInst ) +import Module ( Module ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) @@ -69,7 +70,7 @@ import CmmParse ( parseCmmFile ) import CodeOutput ( codeOutput ) import CmdLineOpts -import DriverPhases ( isExtCoreFilename ) +import DriverPhases ( HscSource(..) ) import ErrUtils import UniqSupply ( mkSplitUniqSupply ) @@ -79,14 +80,13 @@ import HscTypes import MkExternalCore ( emitExternalCore ) import ParserCore import ParserCoreUtils -import Module ( Module, ModLocation(..), showModMsg ) import FastString import Maybes ( expectJust ) import StringBuffer ( StringBuffer ) import Bag ( unitBag, emptyBag ) import Monad ( when ) -import Maybe ( isJust, fromJust ) +import Maybe ( isJust ) import IO import DATA_IOREF ( newIORef, readIORef ) \end{code} @@ -156,35 +156,34 @@ type MessageAction = Messages -> IO () hscMain :: HscEnv - -> MessageAction -- what to do with errors/warnings - -> Module - -> ModLocation -- location info - -> Bool -- True <=> source unchanged - -> Bool -- True <=> have an object file (for msgs only) - -> Maybe ModIface -- old interface, if available + -> MessageAction -- What to do with errors/warnings + -> ModSummary + -> Bool -- True <=> source unchanged + -> Bool -- True <=> have an object file (for msgs only) + -> Maybe ModIface -- Old interface, if available -> IO HscResult -hscMain hsc_env msg_act mod location +hscMain hsc_env msg_act mod_summary source_unchanged have_object maybe_old_iface = do { (recomp_reqd, maybe_checked_iface) <- _scc_ "checkOldIface" - checkOldIface hsc_env mod - (ml_hi_file location) + checkOldIface hsc_env mod_summary source_unchanged maybe_old_iface; let no_old_iface = not (isJust maybe_checked_iface) what_next | recomp_reqd || no_old_iface = hscRecomp | otherwise = hscNoRecomp - ; what_next hsc_env msg_act have_object - mod location maybe_checked_iface + ; what_next hsc_env msg_act mod_summary have_object + maybe_checked_iface } +------------------------------ -- hscNoRecomp definitely expects to have the old interface available -hscNoRecomp hsc_env msg_act have_object - mod location (Just old_iface) +hscNoRecomp hsc_env msg_act mod_summary + have_object (Just old_iface) | isOneShot (hsc_mode hsc_env) = do { compilationProgressMsg (hsc_dflags hsc_env) $ @@ -195,44 +194,133 @@ hscNoRecomp hsc_env msg_act have_object return (HscNoRecomp bomb bomb) } | otherwise - = do { - compilationProgressMsg (hsc_dflags hsc_env) $ - ("Skipping " ++ showModMsg have_object mod location); + = do { compilationProgressMsg (hsc_dflags hsc_env) $ + ("Skipping " ++ showModMsg have_object mod_summary) - new_details <- _scc_ "tcRnIface" + ; new_details <- _scc_ "tcRnIface" typecheckIface hsc_env old_iface ; - dumpIfaceStats hsc_env ; + ; dumpIfaceStats hsc_env - return (HscNoRecomp new_details old_iface) - } + ; return (HscNoRecomp new_details old_iface) + } -hscRecomp hsc_env msg_act have_object - mod location maybe_checked_iface - = do { - -- what target are we shooting for? - ; let one_shot = isOneShot (hsc_mode hsc_env) - ; let dflags = hsc_dflags hsc_env - ; let toInterp = dopt_HscLang dflags == HscInterpreted - ; let toCore = isJust (ml_hs_file location) && - isExtCoreFilename (fromJust (ml_hs_file location)) +------------------------------ +hscRecomp hsc_env msg_act mod_summary + have_object maybe_checked_iface + = case ms_hsc_src mod_summary of + HsSrcFile -> do { front_res <- hscFileFrontEnd hsc_env msg_act mod_summary + ; hscBackEnd hsc_env mod_summary maybe_checked_iface front_res } + + HsBootFile -> do { front_res <- hscFileFrontEnd hsc_env msg_act mod_summary + ; hscBootBackEnd hsc_env mod_summary maybe_checked_iface front_res } + ExtCoreFile -> do { front_res <- hscCoreFrontEnd hsc_env msg_act mod_summary + ; hscBackEnd hsc_env mod_summary maybe_checked_iface front_res } + +hscCoreFrontEnd hsc_env msg_act mod_summary = do { + ------------------- + -- PARSE + ------------------- + ; inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary)) + ; case parseCore inp 1 of + FailP s -> putMsg s{-ToDo: wrong-} >> return Nothing + OkP rdr_module -> do { + + ------------------- + -- RENAME and TYPECHECK + ------------------- + ; (tc_msgs, maybe_tc_result) <- _scc_ "TypeCheck" + tcRnExtCore hsc_env rdr_module + ; msg_act tc_msgs + ; case maybe_tc_result of + Nothing -> return Nothing + Just mod_guts -> return (Just mod_guts) -- No desugaring to do! + }} + + +hscFileFrontEnd hsc_env msg_act mod_summary = do { + ------------------- + -- DISPLAY PROGRESS MESSAGE + ------------------- + let one_shot = isOneShot (hsc_mode hsc_env) + ; let dflags = hsc_dflags hsc_env + ; let toInterp = dopt_HscTarget dflags == HscInterpreted ; when (not one_shot) $ - compilationProgressMsg dflags $ - ("Compiling " ++ showModMsg (not toInterp) mod location); + compilationProgressMsg dflags $ + ("Compiling " ++ showModMsg (not toInterp) mod_summary) - ; let hspp_file = expectJust "hscFrontEnd:hspp" (ml_hspp_file location) - ; front_res <- if toCore then - hscCoreFrontEnd hsc_env msg_act hspp_file - else - hscFileFrontEnd hsc_env msg_act hspp_file (ml_hspp_buf location) + ------------------- + -- PARSE + ------------------- + ; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary) + hspp_buf = ms_hspp_buf mod_summary - ; case front_res of - Left flure -> return flure; - Right ds_result -> do { + ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file hspp_buf + ; case maybe_parsed of { + Left err -> do { msg_act (unitBag err, emptyBag) + ; return Nothing } ; + Right rdr_module -> do { - -- OMITTED: - -- ; seqList imported_modules (return ()) + ------------------- + -- RENAME and TYPECHECK + ------------------- + (tc_msgs, maybe_tc_result) + <- _scc_ "Typecheck-Rename" + tcRnModule hsc_env (ms_hsc_src mod_summary) rdr_module + + ; msg_act tc_msgs + ; case maybe_tc_result of { + Nothing -> return Nothing ; + Just tc_result -> do { + + ------------------- + -- DESUGAR + ------------------- + ; (warns, maybe_ds_result) <- _scc_ "DeSugar" + deSugar hsc_env tc_result + ; msg_act (warns, emptyBag) + ; case maybe_ds_result of + Nothing -> return Nothing + Just ds_result -> return (Just ds_result) + }}}}} + +------------------------------ +hscBootBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult +-- For hs-boot files, there's no code generation to do + +hscBootBackEnd hsc_env mod_summary maybe_checked_iface Nothing + = return HscFail +hscBootBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result) + = do { final_iface <- _scc_ "MkFinalIface" + mkIface hsc_env (ms_location mod_summary) + maybe_checked_iface ds_result + + ; let { final_globals = Just $! (mg_rdr_env ds_result) + ; final_details = ModDetails { md_types = mg_types ds_result, + md_insts = mg_insts ds_result, + md_rules = mg_rules ds_result } } + -- And the answer is ... + ; dumpIfaceStats hsc_env + + ; return (HscRecomp final_details + final_globals + final_iface + False False Nothing) + } + +------------------------------ +hscBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult + +hscBackEnd hsc_env mod_summary maybe_checked_iface Nothing + = return HscFail + +hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result) + = do { -- OMITTED: + -- ; seqList imported_modules (return ()) + + let one_shot = isOneShot (hsc_mode hsc_env) + dflags = hsc_dflags hsc_env ------------------- -- FLATTENING @@ -290,10 +378,9 @@ hscRecomp hsc_env msg_act have_object -- info has been set. Not yet clear if it matters waiting -- until after code output ; new_iface <- _scc_ "MkFinalIface" - mkIface hsc_env location + mkIface hsc_env (ms_location mod_summary) maybe_checked_iface tidy_result - -- Space leak reduction: throw away the new interface if -- we're in one-shot mode; we won't be needing it any -- more. @@ -316,7 +403,7 @@ hscRecomp hsc_env msg_act have_object ------------------- -- CONVERT TO STG and COMPLETE CODE GENERATION ; (stub_h_exists, stub_c_exists, maybe_bcos) - <- hscBackEnd dflags tidy_result + <- hscCodeGen dflags tidy_result -- And the answer is ... ; dumpIfaceStats hsc_env @@ -326,62 +413,7 @@ hscRecomp hsc_env msg_act have_object final_iface stub_h_exists stub_c_exists maybe_bcos) - }} - -hscCoreFrontEnd hsc_env msg_act hspp_file = do { - ------------------- - -- PARSE - ------------------- - ; inp <- readFile hspp_file - ; case parseCore inp 1 of - FailP s -> putMsg s{-ToDo: wrong-} >> return (Left HscFail) - OkP rdr_module -> do { - - ------------------- - -- RENAME and TYPECHECK - ------------------- - ; (tc_msgs, maybe_tc_result) <- _scc_ "TypeCheck" - tcRnExtCore hsc_env rdr_module - ; msg_act tc_msgs - ; case maybe_tc_result of { - Nothing -> return (Left HscFail); - Just mod_guts -> return (Right mod_guts) - -- No desugaring to do! - }}} - - -hscFileFrontEnd hsc_env msg_act hspp_file hspp_buf = do { - ------------------- - -- PARSE - ------------------- - ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file hspp_buf - - ; case maybe_parsed of { - Left err -> do { msg_act (unitBag err, emptyBag) ; - ; return (Left HscFail) ; - }; - Right rdr_module -> do { - - ------------------- - -- RENAME and TYPECHECK - ------------------- - ; (tc_msgs, maybe_tc_result) <- _scc_ "Typecheck-Rename" - tcRnModule hsc_env rdr_module - ; msg_act tc_msgs - ; case maybe_tc_result of { - Nothing -> return (Left HscFail); - Just tc_result -> do { - - ------------------- - -- DESUGAR - ------------------- - ; (warns, maybe_ds_result) <- _scc_ "DeSugar" - deSugar hsc_env tc_result - ; msg_act (warns, emptyBag) - ; case maybe_ds_result of - Nothing -> return (Left HscFail); - Just ds_result -> return (Right ds_result); - }}}}} + } hscFileCheck hsc_env msg_act hspp_file = do { @@ -415,7 +447,7 @@ hscBufferCheck hsc_env buffer msg_act = do hscBufferTypecheck hsc_env rdr_module msg_act = do (tc_msgs, maybe_tc_result) <- _scc_ "Typecheck-Rename" - tcRnModule hsc_env rdr_module + tcRnModule hsc_env HsSrcFile rdr_module msg_act tc_msgs case maybe_tc_result of Nothing -> return (HscChecked rdr_module Nothing) @@ -423,7 +455,7 @@ hscBufferTypecheck hsc_env rdr_module msg_act = do Just r -> return (HscChecked rdr_module (Just r)) -hscBackEnd dflags +hscCodeGen dflags ModGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. mg_module = this_mod, @@ -439,7 +471,7 @@ hscBackEnd dflags prepd_binds <- _scc_ "CorePrep" corePrepPgm dflags core_binds type_env; - case dopt_HscLang dflags of + case dopt_HscTarget dflags of HscNothing -> return (False, False, Nothing) HscInterpreted -> diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 5a0b167..97df435 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -11,6 +11,11 @@ module HscTypes ( ModDetails(..), ModGuts(..), ModImports(..), ForeignStubs(..), + ModSummary(..), showModMsg, + msHsFilePath, msHiFilePath, msObjFilePath, + + HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases + HomePackageTable, HomeModInfo(..), emptyHomePackageTable, hptInstances, hptRules, @@ -81,7 +86,7 @@ import TyCon ( TyCon, tyConSelIds, tyConDataCons ) import DataCon ( dataConImplicitIds ) import Packages ( PackageIdH, PackageId ) import CmdLineOpts ( DynFlags ) - +import DriverPhases ( HscSource(..), isHsBoot, hscSourceString ) import BasicTypes ( Version, initialVersion, IPName, Fixity, defaultFixity, DeprecTxt ) @@ -89,13 +94,14 @@ import IfaceSyn ( IfaceInst, IfaceRule, IfaceDecl(ifName) ) import FiniteMap ( FiniteMap ) import CoreSyn ( IdCoreRule ) -import Maybes ( orElse, fromJust ) +import Maybes ( orElse, fromJust, expectJust ) import Outputable import SrcLoc ( SrcSpan ) import UniqSupply ( UniqSupply ) import FastString ( FastString ) import DATA_IOREF ( IORef, readIORef ) +import StringBuffer ( StringBuffer ) import Time ( ClockTime ) \end{code} @@ -324,6 +330,7 @@ data ModDetails data ModGuts = ModGuts { mg_module :: !Module, + mg_boot :: IsBootInterface, -- Whether it's an hs-boot module mg_exports :: !NameSet, -- What it exports mg_deps :: !Dependencies, -- What is below it, directly or otherwise mg_dir_imps :: ![Module], -- Directly-imported modules; used to @@ -870,6 +877,72 @@ addInstsToPool insts new_insts %************************************************************************ %* * + The ModSummary type + A ModSummary is a node in the compilation manager's + dependency graph, and it's also passed to hscMain +%* * +%************************************************************************ + +The nodes of the module graph are + EITHER a regular Haskell source module + OR a hi-boot source module + +\begin{code} +data ModSummary + = ModSummary { + ms_mod :: Module, -- Name of the module + ms_hsc_src :: HscSource, -- Source is Haskell, hs-boot, external core + ms_location :: ModLocation, -- Location + ms_hs_date :: ClockTime, -- Timestamp of summarised file + ms_srcimps :: [Module], -- Source imports + ms_imps :: [Module], -- Non-source imports + ms_hspp_file :: Maybe FilePath, -- Filename of preprocessed source, + -- once we have preprocessed it. + ms_hspp_buf :: Maybe StringBuffer -- The actual preprocessed source, maybe. + } + +-- The ModLocation contains both the original source filename and the +-- filename of the cleaned-up source file after all preprocessing has been +-- done. The point is that the summariser will have to cpp/unlit/whatever +-- all files anyway, and there's no point in doing this twice -- just +-- park the result in a temp file, put the name of it in the location, +-- and let @compile@ read from that file on the way back up. + +-- The ModLocation is stable over successive up-sweeps in GHCi, wheres +-- the ms_hs_date and imports can, of course, change + +msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath +msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms)) +msHiFilePath ms = ml_hi_file (ms_location ms) +msObjFilePath ms = ml_obj_file (ms_location ms) + + +instance Outputable ModSummary where + ppr ms + = sep [text "ModSummary {", + nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), + text "ms_mod =" <+> ppr (ms_mod ms) + <> text (hscSourceString (ms_hsc_src ms)) <> comma, + text "ms_imps =" <+> ppr (ms_imps ms), + text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), + char '}' + ] + +showModMsg :: Bool -> ModSummary -> String +showModMsg use_object mod_summary + = showSDoc (hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '), + char '(', text (msHsFilePath mod_summary) <> comma, + if use_object then text (msObjFilePath mod_summary) + else text "interpreted", + char ')']) + where + mod = ms_mod mod_summary + mod_str = moduleUserString mod ++ hscSourceString (ms_hsc_src mod_summary) +\end{code} + + +%************************************************************************ +%* * \subsection{Linkable stuff} %* * %************************************************************************ diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index efe4842..7a48726 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,7 +1,7 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.142 2005/01/18 12:18:34 simonpj Exp $ +-- $Id: Main.hs,v 1.143 2005/01/27 10:44:39 simonpj Exp $ -- -- GHC Driver program -- @@ -27,9 +27,10 @@ import HscTypes ( GhciMode(..) ) import Config ( cBooterVersion, cGhcUnregisterised, cProjectVersion ) import SysTools ( initSysTools, cleanTempFiles, normalisePath ) import Packages ( dumpPackages, initPackages, haskell98PackageId, PackageIdH(..) ) -import DriverPipeline ( staticLink, doMkDLL, runPipeline ) -import DriverState ( buildStgToDo, - findBuildTag, unregFlags, +import DriverPipeline ( staticLink, doMkDLL, compileFile ) +import DriverState ( isLinkMode, isMakeMode, isInteractiveMode, + isCompManagerMode, isInterpretiveMode, + buildStgToDo, findBuildTag, unregFlags, v_GhcMode, v_GhcModeFlag, GhcMode(..), v_Keep_tmp_files, v_Ld_inputs, v_Ways, v_Output_file, v_Output_hi, @@ -37,11 +38,11 @@ import DriverState ( buildStgToDo, ) import DriverFlags -import DriverMkDepend ( beginMkDependHS, endMkDependHS ) +import DriverMkDepend ( doMkDependHS ) import DriverPhases ( isSourceFilename ) import DriverUtil ( add, handle, handleDyn, later, unknownFlagsErr ) -import CmdLineOpts ( DynFlags(..), HscLang(..), v_Static_hsc_opts, +import CmdLineOpts ( DynFlags(..), HscTarget(..), v_Static_hsc_opts, defaultDynFlags ) import BasicTypes ( failed ) import Outputable @@ -119,7 +120,7 @@ main = -- -O and --interactive are not a good combination -- ditto with any kind of way selection orig_ways <- readIORef v_Ways - when (notNull orig_ways && isInteractive mode) $ + when (notNull orig_ways && isInterpretiveMode mode) $ do throwDyn (UsageError "--interactive can't be used with -prof, -ticky, -unreg or -smp.") @@ -140,17 +141,17 @@ main = stg_todo <- buildStgToDo - -- set the "global" HscLang. The HscLang can be further adjusted on a module + -- set the "global" HscTarget. The HscTarget can be further adjusted on a module -- by module basis, using only the -fvia-C and -fasm flags. If the global - -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect. + -- HscTarget is not HscC or HscAsm, -fvia-C and -fasm have no effect. let dflags0 = defaultDynFlags let lang = case mode of DoInteractive -> HscInterpreted DoEval _ -> HscInterpreted - _other -> hscLang dflags0 + _other -> hscTarget dflags0 let dflags1 = dflags0{ stgToDo = stg_todo, - hscLang = lang, + hscTarget = lang, -- leave out hscOutName for now hscOutName = panic "Main.main:hscOutName not set", verbosity = case mode of @@ -224,10 +225,7 @@ main = case mode of DoMake -> doMake dflags srcs - - DoMkDependHS -> do { beginMkDependHS ; - compileFiles mode dflags srcs; - endMkDependHS dflags } + DoMkDependHS -> doMkDependHS dflags srcs StopBefore p -> do { compileFiles mode dflags srcs; return () } DoMkDLL -> do { o_files <- compileFiles mode dflags srcs; doMkDLL dflags o_files link_pkgs } @@ -259,29 +257,25 @@ checkOptions mode srcs objs = do -- -ohi sanity check ohi <- readIORef v_Output_hi if (isJust ohi && - (mode == DoMake || isInteractive mode || srcs `lengthExceeds` 1)) + (isCompManagerMode mode || srcs `lengthExceeds` 1)) then throwDyn (UsageError "-ohi can only be used when compiling a single source file") else do -- -o sanity checking o_file <- readIORef v_Output_file - if (srcs `lengthExceeds` 1 && isJust o_file && mode /= DoLink && mode /= DoMkDLL) + if (srcs `lengthExceeds` 1 && isJust o_file && not (isLinkMode mode)) then throwDyn (UsageError "can't apply -o to multiple source files") else do - -- Check that there are some input files (except in the interactive - -- case) - if null srcs && null objs && not (isInteractive mode) + -- Check that there are some input files + -- (except in the interactive case) + if null srcs && null objs && not (isInterpretiveMode mode) then throwDyn (UsageError "no input files") else do -- Verify that output files point somewhere sensible. verifyOutputFiles -isInteractive DoInteractive = True -isInteractive (DoEval _) = True -isInteractive _ = False - -- ----------------------------------------------------------------------------- -- Compile files in one-shot mode. @@ -289,25 +283,7 @@ compileFiles :: GhcMode -> DynFlags -> [String] -- Source files -> IO [String] -- Object files -compileFiles mode dflags srcs = do - stop_flag <- readIORef v_GhcModeFlag - mapM (compileFile mode dflags stop_flag) srcs - - -compileFile mode dflags stop_flag src = do - exists <- doesFileExist src - when (not exists) $ - throwDyn (CmdLineError ("file `" ++ src ++ "' does not exist")) - - o_file <- readIORef v_Output_file - -- when linking, the -o argument refers to the linker's output. - -- otherwise, we use it as the name for the pipeline's output. - let maybe_o_file - | mode==DoLink || mode==DoMkDLL = Nothing - | otherwise = o_file - - runPipeline mode dflags stop_flag True maybe_o_file src - Nothing{-no ModLocation-} +compileFiles mode dflags srcs = mapM (compileFile mode dflags) srcs -- ---------------------------------------------------------------------------- @@ -331,7 +307,7 @@ showBanners mode dflags static_opts = do -- Show the GHCi banner # ifdef GHCI - when (mode == DoInteractive && verb >= 1) $ + when (isInteractiveMode mode && verb >= 1) $ hPutStrLn stdout ghciWelcomeMsg # endif diff --git a/ghc/compiler/main/Packages.lhs-boot b/ghc/compiler/main/Packages.lhs-boot new file mode 100644 index 0000000..3a1712e --- /dev/null +++ b/ghc/compiler/main/Packages.lhs-boot @@ -0,0 +1,4 @@ +\begin{code} +module Packages where +data PackageState +\end{code} diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 0b5d02f..01ad579 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -8,7 +8,7 @@ -- --------------------------------------------------------------------------- { -module Parser ( parseModule, parseStmt, parseIdentifier, parseIface, parseType, +module Parser ( parseModule, parseStmt, parseIdentifier, parseType, parseHeader ) where #define INCLUDE #include @@ -275,7 +275,6 @@ TH_TY_QUOTE { L _ ITtyQuote } -- ''T %name parseModule module %name parseStmt maybe_stmt %name parseIdentifier identifier -%name parseIface iface %name parseType ctype %partial parseHeader header %tokentype { Located Token } @@ -335,52 +334,6 @@ header_body :: { [LImportDecl RdrName] } | vocurly importdecls { $2 } ----------------------------------------------------------------------------- --- Interfaces (.hi-boot files) - -iface :: { ModIface } - : 'module' modid 'where' ifacebody { mkBootIface (unLoc $2) $4 } - -ifacebody :: { ([(Module, IsBootInterface)], [HsDecl RdrName]) } - : '{' ifacetop '}' { $2 } - | vocurly ifacetop close { $2 } - -ifacetop :: { ([(Module, IsBootInterface)], [HsDecl RdrName]) } - : ifaceimps { ($1,[]) } - | ifaceimps ';' ifacedecls { ($1,$3) } - | ifacedecls { ([],$1) } - -ifaceimps :: { [(Module, IsBootInterface)] } -- Reversed, but that's ok - : ifaceimps ';' ifaceimp { $3 : $1 } - | ifaceimp { [$1] } - -ifaceimp :: { (Module, IsBootInterface) } - : 'import' maybe_src modid { (unLoc $3, $2) } - --- The defn of iface decls allows a trailing ';', which the lexer geneates for --- module Foo where --- foo :: () -ifacedecls :: { [HsDecl RdrName] } -- Reversed, but doesn't matter - : ifacedecls ';' ifacedecl { $3 : $1 } - | ifacedecls ';' { $1 } - | ifacedecl { [$1] } - -ifacedecl :: { HsDecl RdrName } - : var '::' sigtype - { SigD (Sig $1 $3) } - | 'type' syn_hdr '=' ctype - { let (tc,tvs) = $2 in TyClD (TySynonym tc tvs $4) } - | 'data' tycl_hdr constrs -- No deriving in hi-boot - { TyClD (mkTyData DataType $2 Nothing (reverse (unLoc $3)) Nothing) } - | 'data' tycl_hdr 'where' gadt_constrlist - { TyClD (mkTyData DataType $2 Nothing (reverse (unLoc $4)) Nothing) } - | 'newtype' tycl_hdr -- Constructor is optional - { TyClD (mkTyData NewType $2 Nothing [] Nothing) } - | 'newtype' tycl_hdr '=' newconstr - { TyClD (mkTyData NewType $2 Nothing [$4] Nothing) } - | 'class' tycl_hdr fds - { TyClD (mkClassDecl (unLoc $2) (unLoc $3) [] emptyBag) } - ------------------------------------------------------------------------------ -- The Export List maybeexports :: { Maybe [LIE RdrName] } diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index d9151a8..c99a8d5 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -13,7 +13,6 @@ module RdrHsSyn ( mkHsDo, mkHsSplice, mkTyData, mkPrefixCon, mkRecCon, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp - mkBootIface, cvBindGroup, cvBindsAndSigs, @@ -185,213 +184,6 @@ mkHsNegApp (L loc e) = f e %************************************************************************ %* * - Hi-boot files -%* * -%************************************************************************ - -mkBootIface, and its deeply boring helper functions, have two purposes: - -a) HsSyn to IfaceSyn. The parser parses the former, but we're reading - an hi-boot file, and interfaces consist of the latter - -b) Convert unqualifed names from the "current module" to qualified Orig - names. E.g. - module This where - foo :: GHC.Base.Int -> GHC.Base.Int - becomes - This.foo :: GHC.Base.Int -> GHC.Base.Int - -It assumes that everything is well kinded, of course. Failure causes a -fatal error using pgmError, rather than a monadic error. You're supposed -to get hi-boot files right! - - -\begin{code} -mkBootIface :: Module -> ([(Module, IsBootInterface)], [HsDecl RdrName]) -> ModIface --- Make the ModIface for a hi-boot file --- The decls are of very limited form --- The package will be filled in later (see LoadIface.readIface) -mkBootIface mod (imports, decls) - = (emptyModIface HomePackage{-fill in later-} mod) { - mi_boot = True, - mi_deps = noDependencies { dep_mods = imports }, - mi_exports = [(mod, map mk_export decls')], - mi_decls = decls_w_vers, - mi_ver_fn = mkIfaceVerCache decls_w_vers } - where - decls' = map hsIfaceDecl decls - decls_w_vers = repeat initialVersion `zip` decls' - - -- hi-boot declarations don't (currently) - -- expose constructors or class methods - mk_export decl | isValOcc occ = Avail occ - | otherwise = AvailTC occ [occ] - where - occ = ifName decl - - -hsIfaceDecl :: HsDecl RdrName -> IfaceDecl - -- Change to Iface syntax, and replace unqualified names with - -- qualified Orig names from this module. Reason: normal - -- iface files have everything fully qualified, so it's convenient - -- for hi-boot files to look the same - -- - -- NB: no constructors or class ops to worry about -hsIfaceDecl (SigD (Sig name ty)) - = IfaceId { ifName = rdrNameOcc (unLoc name), - ifType = hsIfaceLType ty, - ifIdInfo = NoInfo } - -hsIfaceDecl (TyClD decl@(ClassDecl {})) - = IfaceClass { ifName = rdrNameOcc (tcdName decl), - ifTyVars = hsIfaceTvs (tcdTyVars decl), - ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)), - ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)), - ifSigs = [], -- Is this right?? - ifRec = NonRecursive, ifVrcs = [] } - -hsIfaceDecl (TyClD decl@(TySynonym {})) - = IfaceSyn { ifName = rdrNameOcc (tcdName decl), - ifTyVars = hsIfaceTvs (tcdTyVars decl), - ifSynRhs = hsIfaceLType (tcdSynRhs decl), - ifVrcs = [] } - -hsIfaceDecl (TyClD decl@(TyData {})) - = IfaceData { ifName = rdrNameOcc (tcdName decl), - ifTyVars = tvs, - ifCons = hsIfaceCons tvs decl, - ifRec = Recursive, -- Hi-boot decls are always loop-breakers - ifVrcs = [], ifGeneric = False } - -- I'm not sure that [] is right for ifVrcs, but - -- since we don't use them I'm not going to fiddle - where - tvs = hsIfaceTvs (tcdTyVars decl) - -hsIfaceDecl decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl) - -hsIfaceCons :: [IfaceTvBndr] -> TyClDecl RdrName -> IfaceConDecls -hsIfaceCons tvs decl@(TyData {tcdCtxt = L _ stupid_ctxt}) - | not (null stupid_ctxt) -- Keep it simple: no data type contexts - -- Else we'll have to do "thinning"; sigh - = pprPgmError "Can't do data type contexts in hi-boot file:" (ppr decl) - -hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = []}) - = -- data T a, meaning "constructors unspecified", - IfAbstractTyCon -- not "no constructors" - -hsIfaceCons tvs (TyData {tcdND = DataType, tcdCons = cons}) - = IfDataTyCon Nothing (map (hsIfaceCon tvs . unLoc) cons) - -hsIfaceCons tvs (TyData {tcdND = NewType, tcdCons = [con]}) - = IfNewTyCon (hsIfaceCon tvs (unLoc con)) - -hsIfaceCons tvs decl = pprPgmError "Illegal declaration in hi-boot file:" (ppr decl) - - -hsIfaceCon :: [IfaceTvBndr] -> ConDecl RdrName -> IfaceConDecl -hsIfaceCon tvs (ConDecl lname ex_tvs ex_ctxt details) - | null ex_tvs && null (unLoc ex_ctxt) - = IfVanillaCon { ifConOcc = get_occ lname, - ifConInfix = is_infix, - ifConArgTys = map hsIfaceLType args, - ifConStricts = map (hsStrictMark . getBangStrictness) args, - ifConFields = flds } - | null flds - = IfGadtCon { ifConOcc = get_occ lname, - ifConTyVars = tvs ++ hsIfaceTvs ex_tvs, - ifConCtxt = hsIfaceCtxt (unLoc ex_ctxt), - ifConArgTys = map hsIfaceLType args, - ifConResTys = map (IfaceTyVar . fst) tvs, - ifConStricts = map (hsStrictMark . getBangStrictness) args } - | otherwise = pprPgmError "Fields illegal in existential" (ppr (unLoc lname)) - where - (is_infix, args, flds) = case details of - PrefixCon args -> (False, args, []) - InfixCon a1 a2 -> (True, [a1,a2], []) - RecCon fs -> (False, map snd fs, map (get_occ . fst) fs) - get_occ lname = rdrNameOcc (unLoc lname) - -hsIfaceCon _tvs (GadtDecl lname con_ty) -- Not yet - = pprPgmError "Can't use GADTs in hi-boot files (yet)" (ppr (unLoc lname)) - -hsStrictMark :: HsBang -> StrictnessMark --- Warning: in source files the {-# UNPACK #-} pragma (HsUnbox) is a request --- but in an hi-boot file it's interpreted as the Truth! -hsStrictMark HsNoBang = NotMarkedStrict -hsStrictMark HsStrict = MarkedStrict -hsStrictMark HsUnbox = MarkedUnboxed - -hsIfaceName rdr_name -- Qualify unqualifed occurrences - -- with the module name - | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name) - | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name) - -hsIfaceLType :: LHsType RdrName -> IfaceType -hsIfaceLType = hsIfaceType . unLoc - -hsIfaceType :: HsType RdrName -> IfaceType -hsIfaceType (HsForAllTy exp tvs cxt ty) - = foldr (IfaceForAllTy . hsIfaceTv) rho tvs' - where - rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt) - tau = hsIfaceLType ty - tvs' = case exp of - Explicit -> map unLoc tvs - Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty) - -hsIfaceType ty@(HsTyVar _) = hs_tc_app ty [] -hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty [] -hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2) -hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceLType t] -hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t] -hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts) -hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2]) -hsIfaceType (HsParTy t) = hsIfaceLType t -hsIfaceType (HsBangTy _ t) = hsIfaceLType t -hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p) -hsIfaceType (HsKindSig t _) = hsIfaceLType t -hsIfaceType ty = pprPanic "hsIfaceType" (ppr ty) - -- HsNumTy, HsSpliceTy - ------------ -hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys - ------------ -hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType] -hsIfaceCtxt ctxt = map hsIfaceLPred ctxt - ------------ -hsIfaceLPred :: LHsPred RdrName -> IfacePredType -hsIfaceLPred = hsIfacePred . unLoc - -hsIfacePred :: HsPred RdrName -> IfacePredType -hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts) -hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t) - ------------ -hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType -hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args) -hs_tc_app (HsTyVar n) args - | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args - | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args -hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args - ------------ -hsIfaceTvs :: [LHsTyVarBndr RdrName] -> [IfaceTvBndr] -hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs - ------------ -hsIfaceTv (UserTyVar n) = (rdrNameOcc n, liftedTypeKind) -hsIfaceTv (KindedTyVar n k) = (rdrNameOcc n, k) - ------------ -hsIfaceFDs :: [([RdrName], [RdrName])] -> [([OccName], [OccName])] -hsIfaceFDs fds = [ (map rdrNameOcc xs, map rdrNameOcc ys) - | (xs,ys) <- fds ] -\end{code} - -%************************************************************************ -%* * \subsection[cvBinds-etc]{Converting to @HsBinds@, etc.} %* * %************************************************************************ diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 0e01812..291a65e 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -162,12 +162,25 @@ rnTopBinds :: LHsBinds RdrName -- the top level scope resolution does that rnTopBinds mbinds sigs - = bindPatSigTyVars (collectSigTysFromHsBinds (bagToList mbinds)) $ \ _ -> - -- Hmm; by analogy with Ids, this doesn't look right - -- Top-level bound type vars should really scope over - -- everything, but we only scope them over the other bindings - - rnBinds TopLevel mbinds sigs + = do { is_boot <- tcIsHsBoot + ; if is_boot then + rnHsBoot mbinds sigs + else bindPatSigTyVars (collectSigTysFromHsBinds (bagToList mbinds)) $ \ _ -> + -- Hmm; by analogy with Ids, this doesn't look right + -- Top-level bound type vars should really scope over + -- everything, but we only scope them over the other bindings + rnBinds TopLevel mbinds sigs } + +rnHsBoot :: LHsBinds RdrName + -> [LSig RdrName] + -> RnM ([HsBindGroup Name], DefUses) +-- A hs-boot file has no bindings. +-- Return a single HsBindGroup with empty binds and renamed signatures +rnHsBoot mbinds sigs + = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) + ; sigs' <- renameSigs sigs + ; return ([HsBindGroup emptyLHsBinds sigs' NonRecursive], + usesOnly (hsSigsFVs sigs')) } \end{code} @@ -482,7 +495,7 @@ checkSigs ok_sig sigs -- Doesn't seem worth much trouble to sort this. renameSigs :: [LSig RdrName] -> RnM [LSig Name] -renameSigs sigs = mappM (wrapLocM renameSig) (filter (not . isFixitySig . unLoc) sigs) +renameSigs sigs = mappM (wrapLocM renameSig) (filter (not . isFixityLSig) sigs) -- Remove fixity sigs which have been dealt with already renameSig :: Sig RdrName -> RnM (Sig Name) @@ -536,5 +549,9 @@ missingSigWarn var methodBindErr mbind = hang (ptext SLIT("Pattern bindings (except simple variables) not allowed in instance declarations")) - 4 (ppr mbind) + 2 (ppr mbind) + +bindsInHsBootFile mbinds + = hang (ptext SLIT("Bindings in hs-boot files are not allowed")) + 2 (ppr mbinds) \end{code} diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index f927ece..2281f3e 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -308,12 +308,12 @@ rnExpr (RecordCon con_id rbinds) returnM (RecordCon conname rbinds', fvRbinds `addOneFV` unLoc conname) rnExpr (RecordUpd expr rbinds) - = rnLExpr expr `thenM` \ (expr', fvExpr) -> + = rnLExpr expr `thenM` \ (expr', fvExpr) -> rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) -> returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds) rnExpr (ExprWithTySig expr pty) - = rnLExpr expr `thenM` \ (expr', fvExpr) -> + = rnLExpr expr `thenM` \ (expr', fvExpr) -> rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) -> returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) where diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 8ae1e53..4b5bb26 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -14,8 +14,8 @@ module RnNames ( import CmdLineOpts ( DynFlag(..) ) import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, - ForeignDecl(..), HsGroup(..), - collectGroupBinders, tyClDeclNames + ForeignDecl(..), HsGroup(..), HsBindGroup(..), + Sig(..), collectGroupBinders, tyClDeclNames ) import RnEnv import IfaceEnv ( lookupOrig, newGlobalBinder ) @@ -380,12 +380,21 @@ getLocalDeclBinders mod (HsGroup {hs_valds = val_decls, -- an export indicator because they are all implicitly exported. mappM new_tc tycl_decls `thenM` \ tc_avails -> - mappM new_simple (for_hs_bndrs ++ val_hs_bndrs) `thenM` \ simple_avails -> - returnM (tc_avails ++ simple_avails) + + -- In a hs-boot file, the value binders come from the + -- *signatures*, and there should be no foreign binders + tcIsHsBoot `thenM` \ is_hs_boot -> + let val_bndrs | is_hs_boot = sig_hs_bndrs + | otherwise = for_hs_bndrs ++ val_hs_bndrs + in + mappM new_simple val_bndrs `thenM` \ names -> + + returnM (tc_avails ++ map Avail names) where - new_simple rdr_name = newTopSrcBinder mod Nothing rdr_name `thenM` \ name -> - returnM (Avail name) + new_simple rdr_name = newTopSrcBinder mod Nothing rdr_name + sig_hs_bndrs = [nm | HsBindGroup _ lsigs _ <- val_decls, + L _ (Sig nm _) <- lsigs] val_hs_bndrs = collectGroupBinders val_decls for_hs_bndrs = [nm | L _ (ForeignImport nm _ _ _) <- foreign_decls] diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 6ee9f8a..f382282 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -41,7 +41,7 @@ import NameEnv import Outputable import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) import CmdLineOpts ( DynFlag(..) ) - -- Warn of unused for-all'd tyvars +import DriverPhases ( isHsBoot ) import Maybes ( seqMaybe ) import Maybe ( catMaybes, isNothing ) \end{code} @@ -619,14 +619,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, \begin{code} rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name] rnConDecls tycon condecls - = -- Check that there's at least one condecl, - -- or else we're reading an interface file, or -fglasgow-exts - (if null condecls then - doptM Opt_GlasgowExts `thenM` \ glaExts -> - checkErr glaExts (emptyConDeclsErr tycon) - else returnM () - ) `thenM_` - mappM (wrapLocM rnConDecl) condecls + = mappM (wrapLocM rnConDecl) condecls rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) rnConDecl (ConDecl name tvs cxt details) @@ -683,10 +676,6 @@ checkConName name = checkErr (isRdrDataCon name) (badDataCon name) badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] - -emptyConDeclsErr tycon - = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), - nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))] \end{code} diff --git a/ghc/compiler/rename/RnSource.lhs-boot b/ghc/compiler/rename/RnSource.lhs-boot new file mode 100644 index 0000000..28b4aed --- /dev/null +++ b/ghc/compiler/rename/RnSource.lhs-boot @@ -0,0 +1,20 @@ +\begin{code} +module RnSource where +import HsSyn ( HsBindGroup, HsGroup, HsSplice ) +import NameSet ( FreeVars, DefUses ) +import TcRnTypes ( RnM, TcGblEnv ) +import RdrName ( RdrName ) +import Name ( Name ) + +rnBindGroupsAndThen :: forall b . [HsBindGroup RdrName] + -> ([HsBindGroup Name] + -> RnM (b, FreeVars)) + -> RnM (b, FreeVars) + +rnBindGroups :: [HsBindGroup RdrName] -> RnM ([HsBindGroup Name], DefUses) + +rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) +rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) +\end{code} + + diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 7234664..395744d 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -4,7 +4,7 @@ \section[TcBinds]{TcBinds} \begin{code} -module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where +module TcBinds ( tcBindsAndThen, tcTopBinds, tcHsBootSigs, tcMonoBinds, tcSpecSigs ) where #include "HsVersions.h" @@ -14,7 +14,7 @@ import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho ) import CmdLineOpts ( DynFlag(Opt_MonomorphismRestriction) ) import HsSyn ( HsExpr(..), HsBind(..), LHsBinds, Sig(..), LSig, Match(..), HsBindGroup(..), IPBind(..), - HsType(..), hsLTyVarNames, + HsType(..), hsLTyVarNames, isVanillaLSig, LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds, collectHsBindBinders, collectPatBinders, pprPatBind ) @@ -95,15 +95,28 @@ tcTopBinds :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv) -- want. The bit we care about is the local bindings -- and the free type variables thereof tcTopBinds binds - = tc_binds_and_then TopLevel glue binds $ - getLclEnv `thenM` \ env -> - returnM (emptyLHsBinds, env) + = tc_binds_and_then TopLevel glue binds $ + do { env <- getLclEnv + ; return (emptyLHsBinds, env) } where -- The top level bindings are flattened into a giant -- implicitly-mutually-recursive MonoBinds glue (HsBindGroup binds1 _ _) (binds2, env) = (binds1 `unionBags` binds2, env) + glue (HsIPBinds _) _ = panic "Top-level HsIpBinds" -- Can't have a HsIPBinds at top level +tcHsBootSigs :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv) +-- A hs-boot file has only one BindGroup, and it only has type +-- signatures in it. The renamer checked all this +tcHsBootSigs [HsBindGroup _ sigs _] + = do { ids <- mapM (addLocM tc_sig) (filter isVanillaLSig sigs) + ; tcExtendIdEnv ids $ do + { env <- getLclEnv + ; return (emptyLHsBinds, env) }} + where + tc_sig (Sig (L _ name) ty) + = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; return (mkLocalId name sigma_ty) } tcBindsAndThen :: (HsBindGroup TcId -> thing -> thing) -- Combinator @@ -243,7 +256,7 @@ tcBindWithSigs :: TopLevelFlag tcBindWithSigs top_lvl mbind sigs is_rec = do { -- TYPECHECK THE SIGNATURES tc_ty_sigs <- recoverM (returnM []) $ - tcTySigs [sig | sig@(L _(Sig name _)) <- sigs] + tcTySigs (filter isVanillaLSig sigs) ; let lookup_sig = lookupSig tc_ty_sigs -- SET UP THE MAIN RECOVERY; take advantage of any type sigs diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index d5536a1..ad62de6 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -246,7 +246,7 @@ tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, -- default methods. Better to make separate AbsBinds for each let (tyvars, _, _, op_items) = classBigSig clas - prags = filter (isPragSig.unLoc) sigs + prags = filter isPragLSig sigs tc_dm = tcDefMeth clas tyvars default_binds prags dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items] diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index bc1fa9a..7ed64c1 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -219,9 +219,18 @@ tcDeriving tycl_decls -- Add the newtype-derived instances to the inst env -- before tacking the "ordinary" ones + ; let inst_info = newtype_inst_info ++ ordinary_inst_info + + -- If we are compiling a hs-boot file, + -- don't generate any derived bindings + ; is_boot <- tcIsHsBoot + ; if is_boot then + return (inst_info, []) + else do + { + -- Generate the generic to/from functions from each type declaration ; gen_binds <- mkGenericBinds tycl_decls - ; let inst_info = newtype_inst_info ++ ordinary_inst_info -- Rename these extra bindings, discarding warnings about unused bindings etc -- Set -fglasgow exts so that we can have type signatures in patterns, @@ -240,7 +249,7 @@ tcDeriving tycl_decls (ddump_deriving inst_info rn_binds)) ; returnM (inst_info, rn_binds) - } + }} where ddump_deriving :: [InstInfo] -> [HsBindGroup Name] -> SDoc ddump_deriving inst_infos extra_binds diff --git a/ghc/compiler/typecheck/TcExpr.hi-boot b/ghc/compiler/typecheck/TcExpr.hi-boot index 10c75a3791163fff0d69b9ea234ae704853de901..f8aa6235dcf8aa67cdd8492de5a8e51f2d20be70 100644 GIT binary patch literal 3273 zcmchX`Ii$#5XTd9A1eZ0AS&LXvVtg==k8=f;wB_)vfu^MnRK#kCNo1%2R89U0sZUz zgZ#;=Z%>lleZI$U=DmETs;j!Ix~sYq$$$P%B(kTIiA3T&;|${*BogSyBL7pDt;Br7 zj(}+}17^V-myZ~MV zFM*fAkHJsCPr=W?&%rOiHE
    Oii58(NcR@EW)UcEB#U z4PFOtfM0=MgWrJPg5QBR!CT<>;B8QVJkX(La%R^!N-8u3!4koc9KR!`>7T%m#e$_<(!1Y`1tYgU2Rd zcV`1W{C@)SVP;P;IqYAob={5KP?MBe7eo3K*F~h>r*40 zpfA@Vy19v!xmx!l!wW43OwYq2PDAvhN2Y=^qy_sDD;AxhBRtOu{JYjvlOnXHoHJ|& zzUb39d9{TmKP-?XO$P%z-Z8=*Ehco8JK{uX?zT|~oN+u6aRw#F3!;gZb$<{*9rqi` zm#xsSHRX(XBYFDFXJ#p@f#UNhkQ5o=!!zduT2`;~B#51aNu79TA}rC9Bhx4Nodsm6s+h zzoGRaN>xOrIWcwLupet3qm_@nur@Dkp{jgkWYgBPN{OnW&jq1rx$4BP$PoLiMO?C2 ztVq|Ev=+r}ldnbfaYzbH%haNV;;iT}}JLh#py$gxN(lC^ME-mA#5K*(Inbz|=Wi4(o%BT%lTsmUT# zp*1n##E2f&UTIU?iXmO0xW)4E0H1NDEqvvYP^PYrWP3DZH`251P}@Guu|(zKMA}+< z9Gs_SNiha@wXM|{dn~fV%S%3;+*V)5sb;olqX^h(Zb=+RN4t%HLuWf?Xpg&WTW5VT z7~oX%ooUn!0<=J(>u&k;n$j~87bVl3+GbAAtHfU$BG;WpoDjt*l6XUDNkt~Dv`w3) z7bWiJ45$ymkDYX&rV$z+yPno*vhdK7tRqq;hjFadWIbG zJ-S=5yh8VEBt7ra#dzQ-ZNliln<)~gsG9CA%{j6d-q>|zXcX@4aul!DOm({CTjGm7 zQ)^laPW12|b*AW*<(v=g8?3iz==g!5nWC#KH8mBN>zK7(k-pT*jo8SqlZ#p&j&Cs~ zJyY}2lox|-JkNzIHL}L>t-@QRwTrM+y#QA?56wO!)-CR4tK0}Qw^W{PzH|-RE7f&T os>b4RC>qz55Bjt)$WE1^lf13&?r}*8l(j literal 351 zcmc(Z!3x4K5Jb=JSL{(i3%y$Gtx&;UYHlJ+NVZU@Nl0>N|K8XX!7p$x3p2Ajk46*O z4^lCqP|fT-mOwl^>ti6;q?nzkI&172s(>`BNqQMaYf`erEktKR8myPoMED3#ywnIg z#NM>wzL=tCBVVlB@c9Fn=TxV5u{bXB`q5LV)XC^D;9jWwCX*f0S+;N2=73eTa(pTO H%mVNRm%D5V diff --git a/ghc/compiler/typecheck/TcExpr.hi-boot-6 b/ghc/compiler/typecheck/TcExpr.hi-boot-6 index b48197b..318105b 100644 --- a/ghc/compiler/typecheck/TcExpr.hi-boot-6 +++ b/ghc/compiler/typecheck/TcExpr.hi-boot-6 @@ -16,5 +16,5 @@ tcInferRho :: tcMonoExpr :: HsExpr.LHsExpr Name.Name - -> TcUnify.Expected TcType.TcType + -> TcType.Expected TcType.TcType -> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id) diff --git a/ghc/compiler/typecheck/TcExpr.lhs-boot b/ghc/compiler/typecheck/TcExpr.lhs-boot new file mode 100644 index 0000000..0ba20bc --- /dev/null +++ b/ghc/compiler/typecheck/TcExpr.lhs-boot @@ -0,0 +1,27 @@ +\begin{code} +module TcExpr where +import HsSyn ( LHsExpr ) +import Name ( Name ) +import Var ( Id ) +import TcType ( TcType, Expected ) +import TcRnTypes( TcM ) + +tcCheckSigma :: + LHsExpr Name + -> TcType + -> TcM (LHsExpr Id) + +tcCheckRho :: + LHsExpr Name + -> TcType + -> TcM (LHsExpr Id) + +tcInferRho :: + LHsExpr Name + -> TcM (LHsExpr Id, TcType) + +tcMonoExpr :: + LHsExpr Name + -> Expected TcType + -> TcM (LHsExpr Id) +\end{code} diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index bcf08e4..840da46 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -47,7 +47,7 @@ import ForeignCall ( CExportSpec(..), CCallTarget(..), CLabelString, isCLabelString, isDynamicTarget, withDNTypes, DNKind(..), DNCallSpec(..) ) import PrelNames ( hasKey, ioTyConKey ) -import CmdLineOpts ( dopt_HscLang, HscLang(..) ) +import CmdLineOpts ( dopt_HscTarget, HscTarget(..) ) import Outputable import SrcLoc ( Located(..), srcSpanStart ) import Bag ( consBag ) @@ -316,11 +316,11 @@ checkCOrAsmOrDotNetOrInterp other checkCg check = getDOpts `thenM` \ dflags -> - let hscLang = dopt_HscLang dflags in - case hscLang of + let hscTarget = dopt_HscTarget dflags in + case hscTarget of HscNothing -> returnM () otherwise -> - case check hscLang of + case check hscTarget of Nothing -> returnM () Just err -> addErrTc (text "Illegal foreign declaration:" <+> err) \end{code} diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index be08b09..ed58587 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -157,6 +157,7 @@ tcHsSigType ctxt hs_ty ; ty <- tcHsKindedType kinded_ty ; checkValidType ctxt ty ; returnM ty } + -- Used for the deriving(...) items tcHsDeriv :: LHsType Name -> TcM ([TyVar], Class, [Type]) tcHsDeriv = addLocM (tc_hs_deriv []) diff --git a/ghc/compiler/typecheck/TcMatches.hi-boot b/ghc/compiler/typecheck/TcMatches.hi-boot index 80f46b689335d1b902dd99cdcc26197e0c98985a..acff4425f7d52102d32ac5031b9e0bc0c4be3273 100644 GIT binary patch literal 3064 zcmb`IX?xm65XW&02rzD%q*v1PzSG7{nl@KYTNpzP1{<98N}5G1c#Dvf)sh%`rs?tR z`hohYGyjz!&g=3#`e|l%c4u~HR%Dj`{U?*jsijONbD430aS0L$^kb2qo1-=cw1D*rl1>XbDgKOaX;05p^_yKqc{1E&IybN9euY%XW z>)^-WC*Y^xXW-}H7vMU$fm3xMSHMlM3T}Zlunv9+Zi5Z53GRR`unq2ldte9bg8SeN z@Fw^b_%-+q_$~MycniD@eh=OO1=s^Uun$Ub01m+eP=P;yBhUxOwkZSdu8W87yPGNz0f<449%jGr05Fn(qH#@J@G8M}--3_(x!97`2?mNHArbCGo( z7%c{_Kuia2F9sgK#&fMPb-A^0`5j_9a5mL!jJ1W|L%8r#f22N0V>{LCjP_A=_o#a3 zsLH$Ktzd`t#r)IS{$d&9S=(lbdAZC&WpN_bur|+a>2ZgQ^|;L*4|q-M0X;bwOu5Al zI1uab_>vtv zv|wLi#gaR8h3~szaL*3aq=@X0;|`l)Ao^q{ueQ+ShXwMa>2P4}9V5Kad_q@wBTkg& z?i+=`IoB64XRzY>VLZ{Y9t=XL<9a=CUlS)?QrAaGnYCVrq6|refOg%8{$6Ci|6<{x{rKK%aRiKP) z+L~4=Q8f&>AT-UXPJ)Vzu+Lh|B}>GL^lV9M@#bN~)h^WH`Zywm*gy6Rg;jl<6(r9r< z-ml29KuD+Md5L$C#ED)H5Xfn1YO)wrXiZEsF`|dHSKHLKVn|mgX|Y0L;4{v(MW8$q z%GC9-Y>$TQMtZ&-Y1^j`OH?jSq^+gT!Fg()6k~8#+ggpW#}Z4tyyVky_WC+WHMd6_ zMZivTPvST_+G~UyI^Quvd)#H)IvbP00H<2$Oyh1Cq6O&Vu@|H@&392pnw;xSZ8K-n zD)HNfaJti&6C$?~i8qy&RAkat_G#1fMM?TON9q6@A>nSdNgfVM_Vh~-CsE|jT_&hm zGJE-k;10;s%T|u1q;Rh23IF`XwF~4>=+WIuOUE4!NLLp7piCUV0iSZfkCvW1 TcUnify.Expected TcType.TcType + -> TcType.Expected TcType.TcType -> TcRnTypes.TcM (HsExpr.GRHSs Var.Id) tcMatchesFun :: Name.Name -> HsExpr.MatchGroup Name.Name - -> TcUnify.Expected TcType.TcType + -> TcType.Expected TcType.TcType -> TcRnTypes.TcM (HsExpr.MatchGroup Var.Id) diff --git a/ghc/compiler/typecheck/TcMatches.lhs-boot b/ghc/compiler/typecheck/TcMatches.lhs-boot new file mode 100644 index 0000000..ab2c6b0 --- /dev/null +++ b/ghc/compiler/typecheck/TcMatches.lhs-boot @@ -0,0 +1,17 @@ +\begin{code} +module TcMatches where +import HsSyn ( GRHSs, MatchGroup ) +import Name ( Name ) +import Var ( Id ) +import TcType ( TcType, Expected ) +import TcRnTypes( TcM ) + +tcGRHSsPat :: GRHSs Name + -> Expected TcType + -> TcM (GRHSs Id) + +tcMatchesFun :: Name + -> MatchGroup Name + -> Expected TcType + -> TcM (MatchGroup Id) +\end{code} diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 58fdf90..5bd681a 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -1,4 +1,4 @@ -s% +% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcModule]{Typechecking a whole module} @@ -38,7 +38,7 @@ import TcRnMonad import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith ) import Inst ( showLIE ) import InstEnv ( extendInstEnvList ) -import TcBinds ( tcTopBinds ) +import TcBinds ( tcTopBinds, tcHsBootSigs ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv ) import TcRules ( tcRules ) @@ -58,21 +58,24 @@ import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) +import VarEnv ( varEnvElts ) import Module ( Module, ModuleEnv, mkModule, moduleEnvElts ) import OccName ( mkVarOcc ) -import Name ( Name, isExternalName, getSrcLoc, getOccName ) +import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName ) import NameSet import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) -import Outputable +import DriverPhases ( HscSource(..), isHsBoot ) import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..), GhciMode(..), IsBootInterface, noDependencies, Deprecs( NoDeprecs ), plusDeprecs, ForeignStubs(NoStubs), TyThing(..), - TypeEnv, lookupTypeEnv, hptInstances, + TypeEnv, lookupTypeEnv, hptInstances, lookupType, extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, emptyFixityEnv ) +import Outputable + #ifdef GHCI import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..), LStmt, LHsExpr, LHsType, mkMatchGroup, @@ -95,13 +98,14 @@ import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) import RnTypes ( rnLHsType ) import Inst ( tcStdSyntaxName, tcGetInstEnvs ) -import InstEnv ( DFunId, classInstances, instEnvElts ) +import InstEnv ( classInstances, instEnvElts ) import RnExpr ( rnStmts, rnLExpr ) import RnNames ( exportsToAvails ) -import LoadIface ( loadSrcInterface ) +import LoadIface ( loadSrcInterface, ifaceInstGates ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceExtName(..), IfaceConDecls(..), IfaceInst(..), tyThingToIfaceDecl, dfunToIfaceInst ) +import IfaceType ( IfaceTyCon(..), ifPrintUnqual ) import IfaceEnv ( lookupOrig ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) import Id ( Id, isImplicitId, setIdType, globalIdDetails ) @@ -116,9 +120,9 @@ import Var ( globaliseId ) import Name ( nameOccName, nameModule ) import NameEnv ( delListFromNameEnv ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName ) -import Module ( Module, lookupModuleEnv ) +import Module ( lookupModuleEnv ) import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses, - availNames, availName, ModIface(..), + availNames, availName, ModIface(..), icPrintUnqual, ModDetails(..), Dependencies(..) ) import BasicTypes ( RecFlag(..), Fixity ) import Bag ( unitBag ) @@ -145,20 +149,19 @@ import Maybe ( isJust ) \begin{code} tcRnModule :: HscEnv + -> HscSource -> Located (HsModule RdrName) -> IO (Messages, Maybe TcGblEnv) -tcRnModule hsc_env (L loc (HsModule maybe_mod export_ies +tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies import_decls local_decls mod_deprec)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_mod = case maybe_mod of - Nothing -> mAIN - -- 'module M where' is omitted - Just (L _ mod) -> mod } ; - -- The normal case + Nothing -> mAIN -- 'module M where' is omitted + Just (L _ mod) -> mod } ; -- The normal case - initTc hsc_env this_mod $ + initTc hsc_env hsc_src this_mod $ setSrcSpan loc $ do { checkForPackageModule (hsc_dflags hsc_env) this_mod; @@ -194,7 +197,10 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod export_ies traceRn (text "rn1a") ; -- Rename and type check the declarations - tcg_env <- tcRnSrcDecls local_decls ; + tcg_env <- if isHsBoot hsc_src then + tcRnHsBootDecls local_decls + else + tcRnSrcDecls local_decls ; setGblEnv tcg_env $ do { traceRn (text "rn3") ; @@ -263,7 +269,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- The decls are IfaceDecls; all names are original names = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; - initTc hsc_env this_mod $ do { + initTc hsc_env ExtCoreFile this_mod $ do { let { ldecls = map noLoc decls } ; @@ -300,6 +306,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; mod_guts = ModGuts { mg_module = this_mod, + mg_boot = False, mg_usages = [], -- ToDo: compute usage mg_dir_imps = [], -- ?? mg_deps = noDependencies, -- ?? @@ -429,10 +436,56 @@ tc_rn_src_decls boot_names ds %************************************************************************ %* * - Comparing the hi-boot interface with the real thing + Compiling hs-boot source files, and + comparing the hi-boot interface with the real thing %* * %************************************************************************ +\begin{code} +tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv +tcRnHsBootDecls decls + = do { let { (first_group, group_tail) = findSplice decls } + + ; case group_tail of + Just stuff -> spliceInHsBootErr stuff + Nothing -> return () + + -- Rename the declarations + ; (tcg_env, rn_group) <- rnTopSrcDecls first_group + ; setGblEnv tcg_env $ do { + + -- Todo: check no foreign decls, no rules, no default decls + + -- Typecheck type/class decls + ; traceTc (text "Tc2") + ; let tycl_decls = hs_tyclds rn_group + ; tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot_names -}] tycl_decls) + ; setGblEnv tcg_env $ do { + + -- Typecheck instance decls + ; traceTc (text "Tc3") + ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group) + ; setGblEnv tcg_env $ do { + + -- Typecheck value declarations + ; traceTc (text "Tc5") + ; (tc_val_binds, lcl_env) <- tcHsBootSigs (hs_valds rn_group) + + -- Wrap up + -- No simplification or zonking to do + ; traceTc (text "Tc7a") + ; gbl_env <- getGblEnv + + ; let { new_ids = [ id | ATcId id _ _ <- varEnvElts (tcl_env lcl_env) ] + ; final_type_env = extendTypeEnvWithIds (tcg_type_env gbl_env) new_ids } + + ; return (gbl_env { tcg_type_env = final_type_env }) + }}}} + +spliceInHsBootErr (SpliceDecl (L loc _), _) + = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files")) +\end{code} + In both one-shot mode and GHCi mode, hi-boot interfaces are demand-loaded into the External Package Table. Once we've typechecked the body of the module, we want to compare what we've found (gathered in a TypeEnv) with @@ -450,11 +503,14 @@ checkHiBootIface env boot_names ---------------- check_one local_env name - = do { eps <- getEps + | isWiredInName name -- No checking for wired-in names. In particular, 'error' + = return () -- is handled by a rather gross hack (see comments in GHC.Err.hs-boot) + | otherwise + = do { (eps,hpt) <- getEpsAndHpt -- Look up the hi-boot one; -- it should jolly well be there (else GHC bug) - ; case lookupTypeEnv (eps_PTE eps) name of { + ; case lookupType hpt (eps_PTE eps) name of { Nothing -> pprPanic "checkHiBootIface" (ppr name) ; Just boot_thing -> @@ -493,9 +549,9 @@ check_thing boot_thing real_thing -- Default case; failure ---------------- missingBootThing thing - = ppr thing <+> ptext SLIT("is defined in the hi-boot file, but not in the module") + = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module") bootMisMatch thing - = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hi-boot file") + = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file") \end{code} @@ -708,13 +764,22 @@ check_main ghci_mode tcg_env main_mod main_fn \begin{code} #ifdef GHCI -setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a -setInteractiveContext icxt thing_inside - = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_` - (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt, - tcg_type_env = ic_type_env icxt}) $ - updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $ - thing_inside) +setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a +setInteractiveContext hsc_env icxt thing_inside + = let + root_modules :: [(Module, IsBootInterface)] + root_modules = [(mkModule m, False) | m <- ic_toplev_scope icxt] + dfuns = hptInstances hsc_env root_modules + in + updGblEnv (\env -> env { + tcg_rdr_env = ic_rn_gbl_env icxt, + tcg_type_env = ic_type_env icxt, + tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $ + + updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $ + + do { traceTc (text "setIC" <+> ppr (ic_type_env icxt)) + ; thing_inside } \end{code} @@ -731,7 +796,7 @@ tcRnStmt :: HscEnv tcRnStmt hsc_env ictxt rdr_stmt = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext ictxt $ do { + setInteractiveContext hsc_env ictxt $ do { -- Rename; use CmdLineMode because tcRnStmt is only used interactively ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ; @@ -921,7 +986,7 @@ tcRnExpr :: HscEnv -> IO (Maybe Type) tcRnExpr hsc_env ictxt rdr_expr = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext ictxt $ do { + setInteractiveContext hsc_env ictxt $ do { (rn_expr, fvs) <- rnLExpr rdr_expr ; failIfErrsM ; @@ -951,7 +1016,7 @@ tcRnType :: HscEnv -> IO (Maybe Kind) tcRnType hsc_env ictxt rdr_type = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext ictxt $ do { + setInteractiveContext hsc_env ictxt $ do { rn_type <- rnLHsType doc rdr_type ; failIfErrsM ; @@ -1083,7 +1148,7 @@ tcRnGetInfo :: HscEnv -- hence the call to dataTcOccs, and we return up to two results tcRnGetInfo hsc_env ictxt rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ - setInteractiveContext ictxt $ do { + setInteractiveContext hsc_env ictxt $ do { -- If the identifier is a constructor (begins with an -- upper-case letter), then we need to consider both @@ -1113,41 +1178,59 @@ tcRnGetInfo hsc_env ictxt rdr_name -- And lookup up the entities, avoiding duplicates, which arise -- because constructors and record selectors are represented by -- their parent declaration - let { do_one name = do { thing <- tcLookupGlobal name - ; let decl = toIfaceDecl thing + let { do_one name = do { thing <- tcLookupGlobal name ; fixity <- lookupFixityRn name - ; insts <- lookupInsts thing - ; return (decl, fixity, getSrcLoc thing, - map mk_inst insts) } ; + ; insts <- lookupInsts print_unqual thing + ; return (toIfaceDecl thing, fixity, + getSrcLoc thing, insts) } } ; -- For the SrcLoc, the 'thing' has better info than -- the 'name' because getting the former forced the -- declaration to be loaded into the cache - mk_inst dfun = (dfunToIfaceInst dfun, getSrcLoc dfun) ; - cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2 } ; + results <- mapM do_one good_names ; return (fst (removeDups cmp results)) } + where + cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2 + + print_unqual :: PrintUnqualified + print_unqual = icPrintUnqual ictxt -lookupInsts :: TyThing -> TcM [DFunId] -lookupInsts (AClass cls) + +lookupInsts :: PrintUnqualified -> TyThing -> TcM [(IfaceInst, SrcLoc)] +-- Filter the instances by the ones whose tycons (or clases resp) +-- are in scope unqualified. Otherwise we list a whole lot too many! +lookupInsts print_unqual (AClass cls) = do { loadImportedInsts cls [] -- [] means load all instances for cls ; inst_envs <- tcGetInstEnvs - ; return [df | (_,_,df) <- classInstances inst_envs cls] } + ; return [ (inst, getSrcLoc dfun) + | (_,_,dfun) <- classInstances inst_envs cls + , let inst = dfunToIfaceInst dfun + (_, tycons) = ifaceInstGates (ifInstHead inst) + , all print_tycon_unqual tycons ] } + where + print_tycon_unqual (IfaceTc ext_nm) = ifPrintUnqual print_unqual ext_nm + print_tycon_unqual other = True -- Int etc + -lookupInsts (ATyCon tc) +lookupInsts print_unqual (ATyCon tc) = do { eps <- getEps -- Load all instances for all classes that are -- in the type environment (which are all the ones - -- we've seen in any interface file so far + -- we've seen in any interface file so far) ; mapM_ (\c -> loadImportedInsts c []) (typeEnvClasses (eps_PTE eps)) ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all - ; return (get home_ie ++ get pkg_ie) } + ; return [ (inst, getSrcLoc dfun) + | (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie + , relevant dfun + , let inst = dfunToIfaceInst dfun + (cls, _) = ifaceInstGates (ifInstHead inst) + , ifPrintUnqual print_unqual cls ] } where - get ie = [df | (_,_,df) <- instEnvElts ie, relevant df] relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df) - tc_name = tyConName tc + tc_name = tyConName tc -lookupInsts other = return [] +lookupInsts print_unqual other = return [] toIfaceDecl :: TyThing -> IfaceDecl @@ -1158,7 +1241,7 @@ toIfaceDecl thing where ext_nm n = ExtPkg (nameModule n) (nameOccName n) - -- munge transforms a thing to it's "parent" thing + -- munge transforms a thing to its "parent" thing munge (ADataCon dc) = ATyCon (dataConTyCon dc) munge (AnId id) = case globalIdDetails id of RecordSelId tc lbl -> ATyCon tc diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index aeca508..f4fbc06 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -12,9 +12,9 @@ import IOEnv -- Re-export all import HsSyn ( emptyLHsBinds ) import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TyThing, TypeEnv, emptyTypeEnv, + TyThing, TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot, ExternalPackageState(..), HomePackageTable, - Deprecs(..), FixityEnv, FixItem, + Deprecs(..), FixityEnv, FixItem, GhciMode, lookupType, unQualInScope ) import Module ( Module, unitModuleEnv ) import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, @@ -62,13 +62,14 @@ ioToTcRn = ioToIOEnv \begin{code} initTc :: HscEnv + -> HscSource -> Module -> TcM r -> IO (Messages, Maybe r) -- Nothing => error thrown by the thing inside -- (error messages should have been printed already) -initTc hsc_env mod do_this +initTc hsc_env hsc_src mod do_this = do { errs_var <- newIORef (emptyBag, emptyBag) ; tvs_var <- newIORef emptyVarSet ; type_env_var <- newIORef emptyNameEnv ; @@ -79,6 +80,7 @@ initTc hsc_env mod do_this let { gbl_env = TcGblEnv { tcg_mod = mod, + tcg_src = hsc_src, tcg_rdr_env = emptyGlobalRdrEnv, tcg_fix_env = emptyNameEnv, tcg_default = Nothing, @@ -134,13 +136,13 @@ initTc hsc_env mod do_this -- list, and there are no bindings in M, we don't bleat -- "unknown module M". -initTcPrintErrors +initTcPrintErrors -- Used from the interactive loop only :: HscEnv -> Module -> TcM r -> IO (Maybe r) initTcPrintErrors env mod todo = do - (msgs, res) <- initTc env mod todo + (msgs, res) <- initTc env HsSrcFile mod todo printErrorsAndWarnings msgs return res @@ -347,6 +349,9 @@ dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; getModule :: TcRn Module getModule = do { env <- getGblEnv; return (tcg_mod env) } +tcIsHsBoot :: TcRn Bool +tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } + getGlobalRdrEnv :: TcRn GlobalRdrEnv getGlobalRdrEnv = do { env <- getGblEnv; return (tcg_rdr_env env) } diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 5fcd47b..063017e 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -45,7 +45,7 @@ import HsSyn ( PendingSplice, HsOverLit, LRuleDecl, LForeignDecl, ArithSeqInfo, DictBinds, LHsBinds ) import HscTypes ( FixityEnv, HscEnv, TypeEnv, TyThing, - GenAvailInfo(..), AvailInfo, + GenAvailInfo(..), AvailInfo, HscSource(..), availName, IsBootInterface, Deprecations ) import Packages ( PackageId ) import Type ( Type, TvSubstEnv, pprParendType ) @@ -129,6 +129,9 @@ data Env gbl lcl -- Changes as we move into an expression data TcGblEnv = TcGblEnv { tcg_mod :: Module, -- Module being compiled + tcg_src :: HscSource, -- What kind of module + -- (regular Haskell, hs-boot, ext-core) + tcg_rdr_env :: GlobalRdrEnv, -- Top level envt; used during renaming tcg_default :: Maybe [Type], -- Types used for defaulting -- Nothing => no 'default' decl diff --git a/ghc/compiler/typecheck/TcSplice.hi-boot-6 b/ghc/compiler/typecheck/TcSplice.hi-boot-6 index cb93b13..5f28493 100644 --- a/ghc/compiler/typecheck/TcSplice.hi-boot-6 +++ b/ghc/compiler/typecheck/TcSplice.hi-boot-6 @@ -1,14 +1,14 @@ module TcSplice where tcSpliceExpr :: HsExpr.HsSplice Name.Name - -> TcUnify.Expected TcType.TcType + -> TcType.Expected TcType.TcType -> TcRnTypes.TcM (HsExpr.HsExpr Var.Id) kcSpliceType :: HsExpr.HsSplice Name.Name -> TcRnTypes.TcM (HsTypes.HsType Name.Name, TcType.TcKind) tcBracket :: HsExpr.HsBracket Name.Name - -> TcUnify.Expected TcType.TcType + -> TcType.Expected TcType.TcType -> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id) tcSpliceDecls :: HsExpr.LHsExpr Name.Name diff --git a/ghc/compiler/typecheck/TcSplice.lhs-boot b/ghc/compiler/typecheck/TcSplice.lhs-boot new file mode 100644 index 0000000..74a2ca3 --- /dev/null +++ b/ghc/compiler/typecheck/TcSplice.lhs-boot @@ -0,0 +1,21 @@ +\begin{code} +module TcSplice where +import HsSyn ( HsSplice, HsBracket, HsExpr, LHsExpr, HsType, LHsDecl ) +import Var ( Id ) +import Name ( Name ) +import RdrName ( RdrName ) +import TcRnTypes( TcM ) +import TcType ( TcType, TcKind, Expected ) + +tcSpliceExpr :: HsSplice Name + -> Expected TcType + -> TcM (HsExpr Id) + +kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) + +tcBracket :: HsBracket Name + -> Expected TcType + -> TcM (LHsExpr Id) + +tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] +\end{code} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index b008bbe..cd0e234 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -39,7 +39,7 @@ import TcType ( TcKind, ThetaType, TcType, tyVarsOfType, import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType ) import Generics ( validGenericMethodType, canDoGenerics ) import Class ( Class, className, classTyCon, DefMeth(..), classBigSig, classTyVars ) -import TyCon ( TyCon, ArgVrcs, +import TyCon ( TyCon, ArgVrcs, AlgTyConRhs( AbstractTyCon ), tyConDataCons, mkForeignTyCon, isProductTyCon, isRecursiveTyCon, tyConStupidTheta, getSynTyConDefn, isSynTyCon, tyConName ) import DataCon ( DataCon, dataConWrapId, dataConName, dataConSig, @@ -371,14 +371,29 @@ tcTyClDecl1 calc_vrcs calc_isrec { extra_tvs <- tcDataKindSig mb_ksig ; let final_tvs = tvs' ++ extra_tvs ; stupid_theta <- tcStupidTheta ctxt cons + ; want_generic <- doptM Opt_Generics + ; unbox_strict <- doptM Opt_UnboxStrictFields + ; gla_exts <- doptM Opt_GlasgowExts + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + + -- Check that we don't use GADT syntax in H98 world + ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name) + + -- Check that there's at least one condecl, + -- or else we're reading an interface file, or -fglasgow-exts + ; checkTc (not (null cons) || gla_exts || is_boot) + (emptyConDeclsErr tc_name) + ; tycon <- fixM (\ tycon -> do - { unbox_strict <- doptM Opt_UnboxStrictFields - ; gla_exts <- doptM Opt_GlasgowExts - ; checkTc (gla_exts || h98_syntax) (badGadtDecl tc_name) - - ; data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data tycon final_tvs)) cons - ; let tc_rhs = case new_or_data of + { data_cons <- mappM (addLocM (tcConDecl unbox_strict new_or_data + tycon final_tvs)) + cons + ; let tc_rhs + | null cons && is_boot -- In a hs-boot file, empty cons means + = AbstractTyCon -- "don't know"; hence Abstract + | otherwise + = case new_or_data of DataType -> mkDataTyConRhs stupid_theta data_cons NewType -> ASSERT( isSingleton data_cons ) mkNewTyConRhs tycon (head data_cons) @@ -745,4 +760,8 @@ badDataConTyCon data_con badGadtDecl tc_name = vcat [ ptext SLIT("Illegal generalised algebraic data declaration for") <+> quotes (ppr tc_name) , nest 2 (parens $ ptext SLIT("Use -fglasgow-exts to allow GADTs")) ] + +emptyConDeclsErr tycon + = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"), + nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))] \end{code} diff --git a/ghc/compiler/typecheck/TcType.hi-boot b/ghc/compiler/typecheck/TcType.hi-boot index fece21459b462eaa349b8b9c3d68929ab39fc275..8eb641c5ace94cfa05b9e124099c41980dfcfdc4 100644 GIT binary patch literal 314 zcmYL@OA5j;6h)KPPg_NBAxcGX0amJl0|!MXPGSubD6J%&*pa(%;GSHNBi~JH4die? zd5R)JPZyaDfic1$saq@Bp7K6ZI(PE}5Vv@@D0uUg_Aj z$*6n&9t=qIk~F#BBq{GKjGWA-A?a~kXsNDwrJ_oqHxv%ra9?Wj{(3|0lBQY{6?sY~ juuYs5q9o^8x6PsJnVm9!b1d|Qnh`#75PBs`p)&IY{$?+2 literal 88 zcma#g%qvMPN=r;mjaLXs4yi0iRWRg=Ppv4(FDfaH=Yk4_RE8xMxuljPX66)IbH%5m ZCg&s;C6;97=K<9iDx@TqBr2e)0RV}+A7}so diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index c119938..39035dd 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -22,7 +22,7 @@ module TcType ( -------------------------------- -- MetaDetails - TcTyVarDetails(..), + Expected(..), TcRef, TcTyVarDetails(..), MetaDetails(Flexi, Indirect), SkolemInfo(..), pprSkolemTyVar, isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isExistentialTyVar, skolemTvInfo, metaTvRef, isFlexi, isIndirect, @@ -228,6 +228,10 @@ type TcRhoType = TcType type TcTauType = TcType type TcKind = Kind type TcTyVarSet = TyVarSet + +type TcRef a = IORef a +data Expected ty = Infer (TcRef ty) -- The hole to fill in for type inference + | Check ty -- The type to check during type checking \end{code} diff --git a/ghc/compiler/typecheck/TcType.lhs-boot b/ghc/compiler/typecheck/TcType.lhs-boot new file mode 100644 index 0000000..2b7a0c3 --- /dev/null +++ b/ghc/compiler/typecheck/TcType.lhs-boot @@ -0,0 +1,5 @@ +\begin{code} +module TcType where + +data TcTyVarDetails +\end{code} diff --git a/ghc/compiler/typecheck/TcUnify.hi-boot b/ghc/compiler/typecheck/TcUnify.hi-boot index f49026a123524ae04e714d7d60c5c0f3bc1de820..ebb7215c1bae1528ee89accbb680a013c141be20 100644 GIT binary patch literal 2709 zcmZXV`BvLT6vj=AE!#j-l5R=qzNZZ(O`9g^3Ibyn8w+fp8d>UK;p8=l* zp97xJKzqu z3+{oRgI|DOf?t7OgZtnC_zidn3a|_MU=NgF9~^*3paQ=IkHG*O+M*1(x*|pl_XC!i zkuVk*hLJK(7!Mhzj1gnZ_>S>C;|Io%jGq`kGd36=V~cUf5cJFc!Rmm1Q@N=;eSU#t zaKk<+`9WpQvG>;D|+ zu+JS3^HhZ=q6gvzlL!A!Kd0mGgsMLxnO_kD`czg#qWsP%mI+zK6%`82&7{mw#H40c zMn<|(PcA2vyWHHwtcQuw7aXP=U=p_>x-y`qvOAy&dlEBN+<_~Cz>UHa+fm~n$BNwutp{Rrl; z*HEEs#fDq+?vOW9qR(Vxk)rA=K94e~#E1|*9XHaly32zg+oKQz$=gvqUcJISc4(P^ zgQvk{WzkSmVq6&-Evc#C8aiVV&Z;ni7J*a)E#f1Rv#VO2NbMbo1c{ijHf`DPpo%ql zYO+deTA!^_6^Uu4rXCvZ$5z{D6=E-JO;TH~s!$o(v^lL(plT3uLTH#%O~X|gW1qEz zQD!dnlC{&Avt6ns^ob|!>TkCZCsj`-2{atsfc*qrtpti z94)C)7l%9DJhp2#qh1>D)YF?{h$Z-ImvC6pjMQ4*ln+1FU~`YWEg|H>S;B^9xJSPdda8bZ1;2)YGIo;iUr%vZHeP(Yrhfk(#5tJ*yEnH zrL&Uu`#9B7dz5sd2qjSN_}k$mr^OEPNP`QVkuB!wNtXC)mvB0xgae{(6_R^OOG+|X zGxP}g^rB?-T$sE`MG_CHP3qyWvZr5xOyfAfUfD{Kvut#JS8xRs>0>j;DodOzx+1uF zYjKG>l)7}cGCfE4>{tfDy}Oy?Ds95(C>SdelvGXkmd0E;bFZEHGByhL_S}nCYpmKG z>N~?1d#skV798mOzs#|sSC(VGe8E|7k?Z<@Tw_I7S!yaOPS-Wtx-LVhm7j1UzfL}K zIiKBP3VN(2shK@osc4*0%<4k>;+Tr5Z%Ix+Pfl8L{26YPQB+r18R0;zgRJ PI^Xd*SCy3irNI3U&EVph literal 146 zcma#g%qvMPN=r;mjaLXs4$aFj^~1jm4akK5=%oWt-0b;Qj>EM zixNvR^Yeg83>6TP3h`DTb3!T$QuTloNPR)7g03A7v7kJVd@)d|uY!iAg0(dl7Z(5r C(lLwx diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 179a7db..655a0bb 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -34,7 +34,7 @@ import TypeRep ( Type(..), PredType(..), TyNote(..) ) import TcRnMonad -- TcType, amongst others import TcType ( TcKind, TcType, TcSigmaType, TcRhoType, TcTyVar, TcTauType, - TcTyVarSet, TcThetaType, + TcTyVarSet, TcThetaType, Expected(..), SkolemInfo( GenSkol ), MetaDetails(..), pprSkolemTyVar, isTauTy, isSigmaTy, mkFunTys, mkTyConApp, tcSplitAppTy_maybe, tcSplitTyConApp_maybe, @@ -80,9 +80,6 @@ Notes on holes %************************************************************************ \begin{code} -data Expected ty = Infer (TcRef ty) -- The hole to fill in for type inference - | Check ty -- The type to check during type checking - newHole = newMutVar (error "Empty hole in typechecker") tcInfer :: (Expected ty -> TcM a) -> TcM (a,ty) diff --git a/ghc/compiler/typecheck/TcUnify.lhs-boot b/ghc/compiler/typecheck/TcUnify.lhs-boot new file mode 100644 index 0000000..ac6b0c2 --- /dev/null +++ b/ghc/compiler/typecheck/TcUnify.lhs-boot @@ -0,0 +1,10 @@ +\begin{code} +module TcUnify where +import TcType ( TcTauType ) +import TcRnTypes( TcM ) + +-- This boot file exists only to tie the knot between +-- TcUnify and TcSimplify + +unifyTauTy :: TcTauType -> TcTauType -> TcM () +\end{code} diff --git a/ghc/compiler/types/TyCon.hi-boot b/ghc/compiler/types/TyCon.hi-boot index 3d7d4b3785fc69b3abf469abb652246a0e6f2ae6..024339fd1f2c2e39c12e78ee30a20318bce07bdb 100644 GIT binary patch literal 435 zcmZvWO>V+46og+0ln~6K>N%)DNE`s908$q$g1TXofK^#SHi|(4?!mQslrC7Z>YHbN zx@aVSo*BQfL(%n{h%OOh2=st~C>H!dV$t#@VQN4O)PV-@0yKdHXz`*VRHG<{3k(sZ z7$RziO^FeG4)4^YB5xxOV`;2zc@n0irv6Rae^MFy0dY@Yq=TJSu`L1H$noRk0#I1+nn^tU6ImtGz*s)8*%`9~2d>H>UpRQV? bV|=!^_n%S5=lktO-~F5M3tPH_UO(es&0ITM literal 322 zcmaiv&kDjY494$$ioAe>T^)Fs;88rxbBJq%LTyId!F+q`!i3^smykbSlHZ3eWR6c7 z8DV&zB|vMCmq}tyXtblzrD2{tZ^b=4WMNzNE_2Xv;=CqTdNFhcEsvfeWhbFrZNX9| web<$$x{SvSz;;)xxHB`XVW&twh1GU0y7ytkO diff --git a/ghc/compiler/types/TyCon.lhs-boot b/ghc/compiler/types/TyCon.lhs-boot new file mode 100644 index 0000000..83b4b7d --- /dev/null +++ b/ghc/compiler/types/TyCon.lhs-boot @@ -0,0 +1,9 @@ +\begin{code} +module TyCon where + +data TyCon + +isTupleTyCon :: TyCon -> Bool +isUnboxedTupleTyCon :: TyCon -> Bool +isFunTyCon :: TyCon -> Bool +\end{code} diff --git a/ghc/compiler/types/TypeRep.hi-boot b/ghc/compiler/types/TypeRep.hi-boot index c101eb68ecca31399326aaac89e7e21e766529f3..5003cdbf5202ec93339f404252bbecec2f479eef 100644 GIT binary patch literal 388 zcmZ9GOA5j;6h#xi{W)+UiXylG3x2>s5y6R*s-Xs?Ev*w>i)(V?z`Z!~-lSA8@DBI9 zj^&r=BTmcW!45fhUTa2Q!)UqwoTXc8@=O>~GZ;SerL#CBB5Cd9K8)_h}rWr4AP zGu66>UDx2GZ+iTyH17R5=6K2TA}BpncYDj#M&*dkAuiQmJRBkS=UJh2lHPTA*L+f< z8Pv__TEN}K61Ou<)e>gu5#pJf`6Y|5Fvr*`WwtYGUH)X36(_!m3U%TtWc=0ktkVRs G#nu;JlldS_iejN5f* OV7G76<3DqEknjUqA4aeM diff --git a/ghc/compiler/types/TypeRep.lhs-boot b/ghc/compiler/types/TypeRep.lhs-boot new file mode 100644 index 0000000..b99fdd3 --- /dev/null +++ b/ghc/compiler/types/TypeRep.lhs-boot @@ -0,0 +1,8 @@ +\begin{code} +module TypeRep where + +data Type +data PredType +data TyThing +\end{code} + diff --git a/ghc/docs/comm/genesis/modules.html b/ghc/docs/comm/genesis/modules.html index 889d720..a23d053 100644 --- a/ghc/docs/comm/genesis/modules.html +++ b/ghc/docs/comm/genesis/modules.html @@ -73,7 +73,7 @@ identifiers, expressions, rules, and their operations. Literal (TysPrim, PprType)
    DataCon (loop PprType, loop Subst.substTyWith, FieldLabel.FieldLabel)

  1. - TysWiredIn (loop MkId.mkDataConWorkId, loop Generics.mkGenInfo, DataCon.mkDataCon) + TysWiredIn (loop MkId.mkDataConIds)

  2. TcType( lots of TysWiredIn stuff)

  3. @@ -119,8 +119,17 @@ identifiers, expressions, rules, and their operations. - - +HsSyn stuff +
      +
    • HsPat.hs-boot +
    • HsExpr.hs-boot (loop HsPat.LPat) +
    • HsTypes (loop HsExpr.HsSplice) +
    • HsBinds (HsTypes.LHsType, loop HsPat.LPat, HsExpr.pprFunBind and others) + HsLit (HsTypes.SyntaxName) +
    • HsPat (HsBinds, HsLit) + HsDecls (HsBinds) +
    • HsExpr (HsDecls, HsPat) +

    diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs index ce1e0b5..d6da914 100644 --- a/ghc/utils/ghc-pkg/Main.hs +++ b/ghc/utils/ghc-pkg/Main.hs @@ -309,7 +309,7 @@ registerPackage :: FilePath -> IO () registerPackage input defines db_stack auto_ghci_libs update force = do let - db_to_operate_on = head db_stack + db_to_operate_on = my_head "db" db_stack db_filename = fst db_to_operate_on -- checkConfigAccess db_filename @@ -541,7 +541,7 @@ checkDuplicates db_stack pkg update = do when (not update && exposed pkg && not (null exposed_pkgs_with_same_name)) $ die ("trying to register " ++ showPackageId pkgid ++ " as exposed, but " - ++ showPackageId (package (head exposed_pkgs_with_same_name)) + ++ showPackageId (package (my_head "when" exposed_pkgs_with_same_name)) ++ " is also exposed.") @@ -633,9 +633,10 @@ updatePackageDB db_stack pkgs new_pkg = do resolveDep pkgid | realVersion pkgid = pkgid | otherwise = lookupDep (pkgName pkgid) - +-- = pkgid + lookupDep name - = head [ pid | p <- concat (map snd db_stack), + = my_head "dep" [ pid | p <- concat (map snd db_stack), let pid = package p, pkgName pid == name ] @@ -768,7 +769,7 @@ oldRunit clis = do let auto_ghci_libs = any isAuto clis where isAuto OF_AutoGHCiLibs = True; isAuto _ = False - input_file = head ([ f | (OF_Input f) <- clis] ++ ["-"]) + input_file = my_head "inp" ([ f | (OF_Input f) <- clis] ++ ["-"]) force = OF_Force `elem` clis @@ -786,6 +787,9 @@ oldRunit clis = do _ -> do prog <- getProgramName die (usageInfo (usageHeader prog) flags) +my_head s [] = error s +my_head s (x:xs) = x + -- --------------------------------------------------------------------------- #ifdef OLD_STUFF -- 1.7.10.4