-- -- (c) Susumu Katayama -- {-# LANGUAGE TemplateHaskell, MagicHash, CPP #-} -- compile with -package ghc module MagicHaskeller.ExecuteAPI610 {- (loadObj, prepareAPI, executeAPI, unsafeExecuteAPI) -} where import qualified HscMain import GHC import GHC.Exts import GHC.Paths(libdir) -- as instructed in http://haskell.org/haskellwiki/GHC/As_a_library import DynFlags -- (DynFlag, defaultDynFlags, PackageFlag(ExposePackage)) -- , glasgowExtsFlags) はexportされていないらしい. import SrcLoc (SrcSpan(..), noSrcSpan, noSrcLoc, interactiveSrcLoc, noLoc) -- import MyCorePrep( corePrepExpr ) import CorePrep(corePrepExpr) -- コンパイルが通らないのでオリジナルにしてみる import FastString import ByteCodeGen ( coreExprToBCOs ) -- import MyLink -- ( HValue, linkExpr, initDynLinker ) import Linker -- コンパイルが通らないのでオリジナルにしてみる -- import Flattening import HscTypes -- ( HscEnv(..), Session(..), withSession, InteractiveContext(..), mkTypeEnv ) -- also import instance MonadIO Ghc import SimplCore -- import SimplOnce -- コンパイルが通らないのでコメントアウト import VarEnv ( emptyTidyEnv ) import CoreSyn ( CoreExpr, Expr(..), Bind(..) ) -- compiler/coreSyn/CoreSyn.lhs import CoreTidy ( tidyExpr ) import Parser (parseStmt) import Lexer import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType ) import Desugar (deSugarExpr) #if __GLASGOW_HASKELL__ < 708 import PrelNames ( iNTERACTIVE ) #else import PrelNames (mkInteractiveModule) #endif import ErrUtils import StringBuffer (stringToStringBuffer) import Outputable (ppr, pprPanic, showSDocDebug, showSDoc) import TypeRep (pprType, Type) import CoreLint (lintUnfolding) import VarSet (varSetElems) import Panic (panic) import Var -- (Var(..)) import System.IO import System.IO.Unsafe import Data.IORef import System.Exit import Control.Monad(when) -- import Control.Monad.Trans(liftIO) import MagicHaskeller.MyDynamic import qualified MagicHaskeller.CoreLang as CoreLang import Language.Haskell.TH as TH hiding (ppr) import Data.List(isSuffixOf) #ifdef GHC6 -- prelude/TysPrim. import TysPrim(anyPrimTy) #endif import Bag import RdrName import OccName import Convert import HsUtils import HsExpr -- 最後のCoreExpr ---> CoreExprで要るもの． import IdInfo import Data.Char(ord,chr) import qualified Data.Map as Map import qualified MagicHaskeller.Types as Types import Data.List import Unique import Id import UniqSupply import ByteCodeLink(linkBCO,extendClosureEnv) import ByteCodeAsm(UnlinkedBCO(unlinkedBCOName)) import Data.Array -- #define PRELINK pathToGHC :: FilePath -- path to GHC, e.g. "/usr/lib/ghc-6.10.4". 'libdir' can be used instead. pathToGHC = libdir loadObj :: [String] -- ^ visible modules (including package modules). You may omit the Prelude. -> IO (CoreLang.VarLib -> CoreLang.CoreExpr -> Dynamic) loadObj fss = fmap unsafeExecuteAPI $ prepareAPI [] fss -- Just follow http://haskell.org/haskellwiki/GHC/As_a_library -- 問題は，すでに読まれているmoduleはどうするかってことだけど，:loadコマンド同様再読み込み -- addNonPackageTargetってのを定義したので，分ける必要はなくなったはず． prepareAPI :: [FilePath] -- ^ modules to be loaded (except package modules) -> [FilePath] -- ^ visible modules (including package modules) -> IO HscEnv prepareAPI loadfss visfss {- prepareAPI :: [String] -- ^ visible modules (including package modules). -- Supplying @[]@ here works without any problems within GHCi, and currently @prepareAPI@ does not work without --interactive, -- so this argument is actually of no use:( -> IO HscEnv prepareAPI fss -} #if __GLASGOW_HASKELL__ >= 700 # if __GLASGOW_HASKELL__ >= 706 = defaultErrorHandler defaultFatalMessager defaultFlushOut $ # else = defaultErrorHandler defaultLogAction $ # endif #else = defaultErrorHandler defaultDynFlags $ #endif runGhc (Just pathToGHC) $ do -- liftIO $ hPutStrLn stderr "setting up flags" dfs <- getSessionDynFlags -- when (flags dfs /= flags defaultDynFlags) $ error "flags are different" let newf = dfs{ -- opt_P = "-DTEMPLATE_HASKELL" : "-DCLASSIFY" : "-DCHTO" : opt_P dfs, -- defaultDynFlagsのソースが結構参考になったり． packageFlags = [ packageNameToFlag "ghc", packageNameToFlag "old-time", packageNameToFlag "ghc-paths" ] -- , packageNameToFlag "MagicHaskeller" ] {- flags = Opt_TemplateHaskell : Opt_Cpp : -- Opt_FlexibleInstances : Opt_ExistentialQuantification : Opt_PolymorphicComponents : Opt_RelaxedPolyRec : Opt_MagicHash : Opt_RankNTypes : filter (/=Opt_MonomorphismRestriction) (flags dfs) -} } -- Was: Opt_TH -- てゆーか，LibTHをここで読むにはいろんなフラグが.... setSessionDynFlags newf -- result abandoned -- ソースによると結果はDynamic linkingの時に必要ってことだけど，ま，基本的にはDynamic linkingはunsupportedってことか． -- http://hackage.haskell.org/trac/ghc/wiki/DynamicLinking -- ...違う．そのdynamic linkingではない． -- liftIO $ hPutStrLn stderr "loading modules" -- This IS necessary. ts <- mapM (\fs -> guessTarget fs Nothing) loadfss setTargets ts sf <- defaultCleanupHandler newf (load LoadAllTargets) case sf of Succeeded -> return () Failed -> error "failed to load modules" -- liftIO $ hPutStrLn stderr "setting up modules" #if __GLASGOW_HASKELL__ >= 700 modules <- mapM (\fs -> fmap (\x -> (x,Nothing)) $ findModule (mkModuleName fs) Nothing) ("Prelude":visfss) #else modules <- mapM (\fs -> findModule (mkModuleName fs) Nothing) ("Prelude":visfss) #endif #if __GLASGOW_HASKELL__ >= 700 setContext [ IIDecl $ (simpleImportDecl . mkModuleName $ moduleName){GHC.ideclQualified = False} | moduleName <- "Prelude":visfss ] -- GHC 7.4 #else setContext [] modules #endif #ifdef PRELINK -- prelink! newdfs <- getSessionDynFlags initDynLinker newdfs #endif getSession packageNameToFlag :: String -> PackageFlag #if __GLASGOW_HASKELL__ < 710 packageNameToFlag = ExposePackage #else packageNameToFlag name = ExposePackage (PackageArg name) (ModRenaming False []) -- I am not sure this is the correct conversion, because I could not find any documentation on the change. #endif {- -- | @addNonPackageTarget@ adds a target only if the target is not a package module. -- This function assumes there is no package module in the target set of the session. addNonPackageTarget :: Target -> IO () addNonPackageTarget target@(Target targetid _) = catchDyn (addTarget target >> depanal [] False >> return ()) (\str -> if "is a package module" `isSuffixOf` str then removeTarget targetid else throwDyn str) -- depanalがNothingを返す場合，結局後のloadがfailする訳だが，面倒なのでこの段階では放置プレイってことで． -} -- At least I should use a customized version of toString.... unsafeExecuteAPI :: HscEnv -> CoreLang.VarLib -> CoreLang.CoreExpr -> Dynamic unsafeExecuteAPI session vl cece = unsafeToDyn undefined undefined (unsafeCoerce# $ unsafePerformIO $ executeAPI session vl cece) undefined -- unsafeCoerce# is necessary to convert from Dynamic.HValue to HValue. executeAPI :: HscEnv -> CoreLang.VarLib -> CoreLang.CoreExpr -> IO a executeAPI session vl cece = executeTHExp session (CoreLang.exprToTHExp vl cece) executeTHExp :: HscEnv -> TH.Exp -> IO a executeTHExp session the = unwrapCore session =<< compileCoreExpr session the compileCoreExpr :: HscEnv -> TH.Exp -> IO CoreSyn.CoreExpr compileCoreExpr hscEnv the = -- defaultErrorHandler defaultDynFlags $ -- thread killed を表示させたい場合はこっち． {- do res <- compileExpr session $ TH.pprint $ CoreLang.exprToTHExp cece case res of Nothing -> hPutStrLn stderr "Could not execute" >> error "could not execute" Just hv -> return hv -} -- do mbt <- strToCore hscEnv ("let __cmCompileExpr = " ++ TH.pprint the) do mbt <- stmtToCore hscEnv $ thExpToStmt hscEnv the case mbt of Nothing -> error ("could not compile " ++ TH.pprint the ++ " to core.") Just ([i ], ce) -> return ce -- unwrapCore, unwrapCore' の両方が正しく動く．unwrapCoreはghc6.8で動いていたのを持ってきたもので，compileExprHscMainの方をコメントアウトしてrunCoreExprにすると色々はしょる代わりに正しく動かない． unwrapCore :: HscEnv -> CoreSyn.CoreExpr -> IO a unwrapCore hscEnv ce = do -- iohvs <- runCoreExpr hscEnv ce -- (removeIdInfo ce) iohvs <- unsafeCoerce# $ compileExprHscMain hscEnv ce [hv] <- iohvs return hv -- unwrapCore' hscEnv ce = fmap head $ unsafeCoerce# =<< HscMain.compileExpr hscEnv (srcLocSpan interactiveSrcLoc) ce #if __GLASGOW_HASKELL__ >= 700 ce2b dfs pe = coreExprToBCOs dfs undefined pe #else ce2b dfs pe = coreExprToBCOs dfs pe #endif runCoreExpr, runPrepedCoreExpr :: HscEnv -> CoreExpr -> IO a runCoreExpr hscEnv ce = -- repeatIO 10 $ do let dfs = hsc_dflags hscEnv #if __GLASGOW_HASKELL__ >= 706 pe <- corePrepExpr dfs hscEnv ce -- runPrepedCoreExprとの違いはこのcorePrepExprがあるかどうかだけ #else pe <- corePrepExpr dfs ce -- runPrepedCoreExprとの違いはこのcorePrepExprがあるかどうかだけ #endif bcos <- -- repeatIO 10 $ ce2b dfs pe #ifdef PRELINK hv <- linkTheExpr bcos #else hv <-linkExpr hscEnv noSrcSpan bcos #endif return $ unsafeCoerce# hv runPrepedCoreExpr hscEnv ce = -- repeatIO 10 $ do let dfs = hsc_dflags hscEnv bcos <- ce2b dfs ce -- repeatIO 10 $ #ifdef PRELINK hv <- linkTheExpr bcos #else hv <-linkExpr hscEnv noSrcSpan bcos #endif return $ unsafeCoerce# hv #ifdef PRELINK -- | If already prelinked linkTheExpr can be used in place of linkExpr. linkTheExpr :: UnlinkedBCO -> IO HValue linkTheExpr ulbco = do pls <- readIORef v_PersistentLinkerState let ie = itbl_env pls ce = closure_env pls nm = unlinkedBCOName ulbco fixIO (\hv -> linkBCO ie (extendClosureEnv ce [(nm,hv)]) ulbco) #endif -- The type of LStmt has changed during move to GHC 7.8.1. -- stmtToCore :: HscEnv -> HsExpr.LStmt RdrName.RdrName -> IO (Maybe ([Id], CoreExpr)) stmtToCore hscEnv pst = do let dfs = hsc_dflags hscEnv icxt = hsc_IC hscEnv #if __GLASGOW_HASKELL__ >= 708 (tcmsgs, mbtc) <- tcRnStmt hscEnv pst #else (tcmsgs, mbtc) <- tcRnStmt hscEnv icxt pst #endif case mbtc of Nothing -> perror dfs tcmsgs #if __GLASGOW_HASKELL__ >= 706 Just (ids, tc_expr, _fixtyenv) -> do -- desugar #else Just (ids, tc_expr) -> do -- desugar #endif #if __GLASGOW_HASKELL__ >= 708 (desmsgs, mbds) <- deSugarExpr hscEnv tc_expr #else # if __GLASGOW_HASKELL__ >= 700 let typeEnv = mkTypeEnv (ic_tythings icxt) # else let typeEnv = mkTypeEnv (map AnId (ic_tmp_ids icxt)) # endif (desmsgs, mbds) <- deSugarExpr hscEnv iNTERACTIVE (ic_rn_gbl_env icxt) typeEnv tc_expr #endif case mbds of Nothing -> perror dfs desmsgs Just ds -> return (Just (ids, ds)) #if __GLASGOW_HASKELL__ >= 706 perror dfs (wmsg,emsg) = printBagOfErrors dfs wmsg >> printBagOfErrors dfs emsg >> return Nothing #else # if __GLASGOW_HASKELL__ >= 700 perror dfs (wmsg,emsg) = let sdocs = pprErrMsgBag wmsg ++ pprErrMsgBag emsg in mapM_ (printError noSrcSpan) sdocs >> return Nothing # else perror dfs msg = printErrorsAndWarnings dfs msg >> return Nothing # endif #endif -- thExpToStmt :: HscEnv -> TH.Exp -> HsExpr.LStmt RdrName.RdrName thExpToStmt hscEnv = wrapLHsExpr . thExpToLHsExpr hscEnv -- wrapLHsExpr :: HsExpr.LHsExpr RdrName.RdrName -> HsExpr.LStmt RdrName.RdrName wrapLHsExpr expr = noLoc $ LetStmt (HsValBinds (ValBindsIn (Bag.unitBag (HsUtils.mk_easy_FunBind noSrcSpan (Unqual $ mkOccName OccName.varName "__cmCompileExpr") [] expr)) [])) thExpToLHsExpr :: HscEnv -> TH.Exp -> HsExpr.LHsExpr RdrName.RdrName thExpToLHsExpr hscEnv e = case Convert.convertToHsExpr noSrcSpan e of #if __GLASGOW_HASKELL__ >= 706 Left msg -> error $ showSDoc (hsc_dflags hscEnv) msg #else Left msg -> error $ showSDoc msg #endif Right expr -> expr -- unused, but may be useful in future #if __GLASGOW_HASKELL__ < 706 instance Show b => Show (Expr b) where showsPrec p (Var var) = ("Var "++) . (showSDocDebug (ppr var) ++) showsPrec _ (Lit l) = ("Lit "++) . shows l showsPrec _ (App e0@(App _ _) e1) = shows e0 . (" `App` "++) . showParen True (shows e1) showsPrec _ (App e0 e1) = showParen True (shows e0) . (" `App` "++) . showParen True (shows e1) showsPrec _ (Lam v e) = ('\\':) . shows v . shows e showsPrec _ (Let bs e) = ("let"++) . shows bs . (" in "++) . shows e showsPrec _ (Case _ _ _ _) = ("case"++) showsPrec _ (Cast e t) = ("Cast "++) . showParen True (shows e) . (""++) -- showsPrec _ (Note _ _) = ("Note"++) showsPrec _ (Type t) = (showSDoc (pprType t) ++) instance Show b => Show (Bind b) where showsPrec _ (NonRec b e) = (' ':) . shows b . (" = "++) . shows e showsPrec _ (Rec ts ) = ("rec { "++) . foldr (.) id (map hoge ts) . (" } "++) hoge :: Show b => (b, Expr b) -> ShowS hoge (b, e) = shows b . (" = "++) . shows e . (" ; "++) #endif {- unused. also, anyPrimTy does not appear in ghc-7.* any longer -- remove the type info to see if they are necessary even when there is no ad-hoc polymorphism removeTInfo :: Expr b -> Expr b removeTInfo (App e0 e1) = App (removeTInfo e0) (removeTInfo e1) removeTInfo (Lam v e) = Lam v (removeTInfo e) removeTInfo (Let bs e) = Let (rtis bs) (removeTInfo e) removeTInfo (Type t) = Type anyPrimTy removeTInfo (Cast e t) = Cast (removeTInfo e) t removeTInfo e = e rtis (NonRec b e) = NonRec b (removeTInfo e) rtis (Rec ts) = Rec [ (b, removeTInfo e) | (b,e) <- ts ] -} compileExprHscMain :: HscEnv -> CoreExpr -> IO HValue compileExprHscMain hscEnv ce = do let dflags = hsc_dflags hscEnv smpl <- simplifyExpr dflags ce #if __GLASGOW_HASKELL__ >= 706 prep <- corePrepExpr dflags hscEnv smpl #else prep <- corePrepExpr dflags smpl #endif bcos <- ce2b dflags prep linkExpr hscEnv noSrcSpan bcos #ifdef GHC6 {- directLoadObj :: [String] -- ^ visible modules (including package modules). You may omit the Prelude. -> [(a, TH.Exp, TH.Type)] -> IO (CoreLang.CoreExpr -> Dynamic) directLoadObj fss tups = defaultErrorHandler defaultDynFlags $ do hscEnv <- prepareAPI [] fss #ifdef PRELINK hPutStrLn stderr "prelink! (temporarily)" compileExpr hscEnv "([], (:), list_para)" -- compileExpr session "([]::[a], (:)::a->[a]->[a], list_para::[b]->a->(b->[b]->a->a)->a)" -- compileExpr "([]::[Char], (:)::Char->[Char]->[Char], list_para::[Char]->Int-> #endif gm <- mkGlobalAr hscEnv tups return $ unsafeDirectExecuteAPI hscEnv gm -} unsafeDirectExecuteAPI hscEnv gm ce = unsafePerformIO $ directExecuteAPI hscEnv gm ce directExecuteAPI :: HscEnv -> GlobalAr -> CoreLang.CoreExpr -> IO a directExecuteAPI hscEnv gm ce = runCoreExpr hscEnv $ ceToCSCE gm ce -- Note: MagicHaskeller.Primitive = (HValue, TH.Exp, TH.Type) -- Use -- typeToTHType :: TyConLib -> Types.Type -> TH.Type -- if necessary. TyConLib can be undefined here. compileVar :: HscEnv -> (a, TH.Exp, TH.Type) -> IO CoreSyn.CoreExpr compileVar hscEnv (_, the, ty) = do csce <- compileCoreExpr hscEnv the -- これだと，[| (==)::Char->Char->Bool |]みたいな場合にtheが単にVarE '(==)になってうまくいかない．(ad hocなtyvarがinstantiateされない) -- Just (_,csce) <- strToCore session ("let __compileExpr = ("++TH.pprint the ++")::"++TH.pprint (unforall ty)) let unr = unwrap csce putStrLn ("csce = "++show unr) case ty of TH.ForallT tvs [] _ -> do let dfs = hsc_dflags hscEnv simplifyExpr dfs $ foldl CoreSyn.App unr $ replicate (length tvs) $ CoreSyn.Type anyPrimTy -- CorePrep は 不要なはずではあるが，どうするよ？ _ -> return unr unwrap (Let (Rec ((_,e):_)) _) = e -- unwrap (Let (Rec [(_,e)]) _) = e -- こっちだとなぜかダメで，その辺にバグのにほひが.... unwrap st = error (show st) unforall (TH.ForallT _ _ t) = t unforall t = t type GlobalMap = Map.Map String CoreSyn.CoreExpr -- Stringの代わりにTH.Nameなどにしようとすると，ちゃんとequivalenceが思い通りの結果になってくれない．． mkGlobalMap :: HscEnv -> [(a, TH.Exp, TH.Type)] -> IO GlobalMap -- てゆーか，CoreLang.CoreExprのPrimitiveがCoreSyn.CoreExprの情報を持つのが速い． -- data CoreExpr a = ... みたいにして，CoreExpr CoreSyn.CoreExprみたいに使う． mkGlobalMap hscEnv tups = do ces <- mapM (compileVar hscEnv) tups return $ Map.fromList $ zip (map (\(_,b,_) -> thToBaseString b) tups) ces {- -- See Linker.linkDependencies linkDeps :: Session -> [Module] -> IO Bool linkDeps session mods = てゆーか最初に"([],(:),list_para,lines,take)"みたいなのをcompileExprしてしまえばprelinkされるのでは？ -- obtain the set of modules required to be linked cscesToNeededModules :: [CoreSyn.CoreExpr] -> [Module] cscesToNeededModules csces = [ GHC.nameModule n | csce <- csces, var <- csceToVars' csce [], let n = Var.varName n, isExternalName n, not (isWiredInName n) ] -- Should I define instance Generic (Expr b)? csceToVars' :: CoreSyn.CoreExpr -> [Var.Var] -> [Var.Var] csceToVars' (Var var) = (var:) csceToVars' (App e0 e1) = csceToVars' e0 . csceToVars' e1 csceToVars' (Lam _ e) = csceToVars' e csceToVars' (Let (NonRec _ e0) e1) = csceToVars' e0 . csceToVars' e1 csceToVars' (Let (Rec tups) e) = foldr (.) (csceToVars' e) [ csceToVars' a | (_,a) <- tups ] csceToVars' (Case e _ _ tups) = foldr (.) (csceToVars' e) [ csceToVars' a | (_,_,a) <- tups ] csceToVars' (Cast e _) = csceToVars' e csceToVars' (Note _ e) = csceToVars' e csceToVars' _ = id -- Lit case and Type case -} thExpToCSCE :: GlobalMap -> TH.Exp -> CoreSyn.CoreExpr thExpToCSCE gm ce = ctc [] ce where ctc pvs (TH.LamE pvars e) = foldr CoreSyn.Lam (ctc (pvars++pvs) e) (map (mkStrVar . show . unVarP) pvars) ctc pvs (e0 `TH.AppE` e1) = ctc pvs e0 `CoreSyn.App` ctc pvs e1 ctc pvs (InfixE (Just e0) e (Just e1)) = lup e `CoreSyn.App` ctc pvs e0 `CoreSyn.App` ctc pvs e1 ctc pvs (TH.VarE name) | VarP name `elem` pvs = CoreSyn.Var $ mkStrVar $ show name -- VarEの場合，lambda boundの場合と，globalの場合とで扱いが異なる． -- スコープをまじめに考えると，lambda boundかどうかをチェックしてからglobalにあるかどうかをみることになる． ctc pvs e = lup e lup e = case Map.lookup (thToBaseString e) gm of Nothing -> error (show e ++ ", i.e.,\n" ++ TH.pprint e ++ " : could not convert to CoreSyn.CoreExpr") Just csce -> csce thToBaseString (ConE name) = nameBase name thToBaseString (VarE name) = nameBase name unVarP (TH.VarP n) = n mkIntVar i = Id.mkUserLocal (mkVarOcc [chr i]) (Unique.getUnique i) anyPrimTy noSrcSpan mkStrVar str = Id.mkUserLocal (mkVarOcc str) (Unique.getUnique $ mkFastString str) anyPrimTy noSrcSpan type GlobalAr = Array Int CoreSyn.CoreExpr mkGlobalAr :: HscEnv -> [(a, TH.Exp, TH.Type)] -> IO GlobalAr mkGlobalAr hscEnv tups = do ces <- mapM (compileVar hscEnv) tups return $ listArray (0, length tups - 1) ces ceToCSCE :: GlobalAr -> CoreLang.CoreExpr -> CoreSyn.CoreExpr ceToCSCE ga ce = ctc (ord 'a'-1) ce where ctc dep (CoreLang.Lambda e) = CoreSyn.Lam (mkIntVar (dep+1)) $ ctc (dep+1) e ctc dep (CoreLang.X n) = CoreSyn.Var $ mkIntVar (dep-n) ctc dep (CoreLang.Primitive n _) = ga ! n ctc dep (e0 CoreLang.:$ e1) = ctc dep e0 `CoreSyn.App` ctc dep e1 es = map mkIntVar [ord 'e'..] as = map mkIntVar [128..] -- 無理がある? xs = map mkIntVar [192..] hd = mkIntVar (ord 'a') -- これは引数にしても良い mkTV :: Int -> Types.Type mkTV = Types.TV tvrs = map mkTV [1..] tvas = map mkTV [2000..] tvr = mkTV 0 -- ({} \ hd e1..em a1..an -> {hd e1..em a1..an} let x1 = {e1 a1..an} e1 a1..an in {hd x1 e2..em a1..an} let x2 = {e2 a1..an} e2 a1..an in .. {hd x1..xm-1 em a1..an} let xm = {em a1..an} em a1..an in {hd x1..xm} hd x1..xm -- てか，一番上がemptyVarSetであることを除けば，あとはundefinedでいいはず．... と思ったけど，schemeEの定義を見た感じlet bindingsの右辺の一番外側に関しては必要みたい．see notes on Aug. 12, 2008 -- ({} \ hd e1..em a1..an -> let x1 = {e1 a1..an} e1 a1..an in let x2 = {e2 a1..an} e2 a1..an in .. let xm = {em a1..an} em a1..an in hd x1..xm -- という程度の情報があれば十分． -- (\hd e1..em a1..an -> let x1 = e1 a1..an in .. let xm = em a1..an in hd x1..xm) :: (r1->..->rm->r) -> (a1->..->an->r1)->..->(a1->..->an->rm) -> a1->..->an -> r hdmnPreped :: Int -> Int -> CoreSyn.CoreExpr hdmnPreped m 0 = hdmn m 0 -- 要はidを生成するってこと． hdmnPreped m n = lambdas $ lets $ foldl CoreSyn.App (CoreSyn.Var hd) (map CoreSyn.Var mxs) where mes = take m es mxs = take m xs nas = take n as lambdas = flip (foldr ($)) (map CoreSyn.Lam (hd : mes ++ nas)) lets = flip (foldr CoreSyn.Let) binds where binds = zipWith CoreSyn.NonRec mxs $ map appa1an mes where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas -- CorePrep 前のものを生成する場合 -- (\hd e1..em a1..an -> hd (e1 a1..an) .. (em a1..an)) :: (r1->..->rm->r) -> (a1->..->an->r1)->..->(a1->..->an->rm) -> a1->..->an -> r hdmn m n = lambdas $ foldl CoreSyn.App (CoreSyn.Var hd) $ map appa1an mes where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas mes = take m es nas = take n as lambdas = flip (foldr ($)) (map CoreSyn.Lam (hd : mes ++ nas)) hdmnty :: Int -> Int -> Types.Type hdmnty m n = hdty Types.:-> foldr (Types.:->) (foldr (Types.:->) tvr nas) (map (\r -> foldr (Types.:->) r nas) mrs) where hdty = foldr (Types.:->) tvr mrs mrs = take m tvrs nas = take n tvas -- (\e1..em a1..an -> let x1 = e1 a1..an in .. let xm = em a1..an in ai x1 .. xm) -- more exactly, not ai but ai-1 because (!!) counts starting 0 -- :: (a1->..->(r1->..->rm->r)->..->an->r1)->..->(a1->..->(r1->..->rm->r)->..->an->rm) -> -- a1->..->(r1->..->rm->r)->..->an -> r -- aimnPreped i m 0 = aimn i m 0 -- これはありえないケース aimnPreped i m n = lambdas $ foldl CoreSyn.App (CoreSyn.Var (as!!i)) (map CoreSyn.Var mxs) where mes = take m es mxs = take m xs nas = take n as lambdas = flip (foldr ($)) (map CoreSyn.Lam (mes ++ nas)) lets = flip (foldr CoreSyn.Let) binds where binds = zipWith CoreSyn.NonRec mxs $ map appa1an mes where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas -- CorePrep前のものを生成する場合 -- (\e1..em a1..an -> ai (e1 a1..an) .. (em a1..an)) -- more exactly, not ai but ai-1 because (!!) counts starting 0 -- :: (a1->..->(r1->..->rm->r)->..->an->r1)->..->(a1->..->(r1->..->rm->r)->..->an->rm) -> -- a1->..->(r1->..->rm->r)->..->an -> r aimn i m n = lambdas $ foldl CoreSyn.App (CoreSyn.Var (as!!i)) $ map appa1an mes where appa1an var = foldl CoreSyn.App (CoreSyn.Var var) $ map CoreSyn.Var nas mes = take m es nas = take n as lambdas = flip (foldr ($)) (map CoreSyn.Lam (mes ++ nas)) aimnty :: Int -> Int -> Int -> Types.Type aimnty i m n = foldr (Types.:->) (foldr (Types.:->) tvr nas) (map (\r -> foldr (Types.:->) r nas) mrs) where hdty = foldr (Types.:->) tvr mrs mrs = take m tvrs nas = case splitAt i tvas of (tk,_:dr) -> tk ++ hdty : take (n-i-1) dr -- hdmntyとの違いはここだけ mkHdmn :: HscEnv -> Int -> Int -> IO Dynamic mkHdmn hscEnv m n = do let ce = hdmn m n val <- runCoreExpr hscEnv ce return $ unsafeToDyn undefined (hdmnty m n) val undefined -- (CoreLang.exprToTHExp undefined ce) CoreLangではなくてCoreSynから mkAimn :: HscEnv -> Int -> Int -> Int -> IO Dynamic mkAimn hscEnv i m n = do let ce = aimn i m n val <- runCoreExpr hscEnv ce return $ unsafeToDyn undefined (aimnty i m n) val undefined -- (CoreLang.exprToTHExp undefined ce) #endif -- ifdef GHC6 -- こっからプロファイル用 repeatN n f x = force $ map f $ replicate n x repeatIO n act = fmap force $ sequence $ replicate n act -- force (x:xs) = all (x==) xs `seq` x force = foldr1 seq instance Eq (Expr a) where Var i == Var j = True -- i==j Lit l == Lit m = l==m App f e == App g i = g==f && e==i Lam b e == Lam c f = {- b==c && -} e==f Let b e == Let c f = {- b==c && -} e==f Case e b t ab == Case f c u bc = e==f {- && b==c && t==u && ab == bc -} Cast e c == Cast f d = e==f {- && c==d -} -- Note n e == Note m f = {- n==m && -} e==f Type t == Type u = True -- t==u