-- -- (c) Susumu Katayama -- CoreLang.lhs extracted haskell-src-free stuff that can be used with Hat. (This looks like Bindging.hs....) \begin{code} {-# LANGUAGE CPP, ExistentialQuantification, RankNTypes, TemplateHaskell #-} -- workaround Haddock invoked from Cabal unnecessarily chasing imports. (If cpp fails, haddock ignores the remaining part of the module.) #ifndef __GLASGOW_HASKELL__ -- x #hoge #endif module MagicHaskeller.CoreLang where import Language.Haskell.TH import Data.Array import Debug.Trace import qualified MagicHaskeller.PolyDynamic as PD -- import MagicHaskeller.MyDynamic import Data.Char(chr,ord) import MagicHaskeller.TyConLib import MagicHaskeller.ReadTHType(thTypeToType) #ifdef FORCE import Control.Parallel.Strategies #endif -- required to make sure expressions are ready, so we can measure the exact time consumed to execute the expressions before time out. import Data.Bits import Data.HashTable(hashInt, prime) import Data.Function(fix) infixl :$ data CoreExpr = S | K | I | B | C | S' | B' | C' | Y | Lambda CoreExpr | X Int -- de Bruijn notation | FunLambda CoreExpr | FunX Int -- different system of de Bruijn notation for functions, used by IOPairs.hs | Tuple Int | Primitive Int Bool -- True if the primitive is a constructor expression | CoreExpr :$ CoreExpr | Case CoreExpr [(Int,Int,CoreExpr)] -- the case expression. [(primitive ID of the constructor, arity of the constructor, rhs of ->)] | Fix CoreExpr Int [Int] -- Fix expr n is === foldl (:$) (Y :$ FunLambda (napply n Lambda expr)) (map X is) {- | FixCase [(Int,Int,CoreExpr)] -- FixCase ts === (Y :$ Lambda (Lambda (Case (X 0) ts))) -- See notes on July 3, 2010 -} | VarName String -- This is only used for pretty printing IOPairs.Expr. Use de Bruijn variables for other purposes. deriving (Read, Eq, Show, Ord) -- required to make sure expressions are ready, so we can measure the exact time consumed to execute the expressions before time out. #ifdef FORCE instance NFData CoreExpr where rnf (Lambda e) = rnf e rnf (X i) = rnf i rnf (Tuple i) = rnf i rnf (Primitive _ _) = () -- 最後のパターンにマッチするのでこれは要らなかったか． rnf (c :$ d) = rnf c `seq` rnf d rnf e = () #endif {- unused due to inefficiency ceToInteger (Lambda e) = ceToInteger e -- 型が変わっちゃうのでLambdaは無視できるはず．... といいつつ自信無．July 24, 2008のnotesを参照. ま，hashには使えるという程度のつもり． ceToInteger (f :$ e) = 3 * (ceToInteger f `interleave` ceToInteger e) ceToInteger (X n) = 3 * toInteger n + 1 ceToInteger (Primitive n _) = 3 * toInteger n + 2 0 `interleave` 0 = 0 i `interleave` j = (j `interleave` (i `shiftR` 1)) * 2 + (i `mod` 2) -- IntegerでなくIntを使う場合，算術右シフトshiftRでなく論理右シフトを使う必要がある...のはいいけど，なぜライブラリに論理右シフトがない? logShiftR1 n = (n `clearBit` 0) `rotateR` 1 -} instance Enum CoreExpr where fromEnum (Lambda e) = fromIntegral prime * fromEnum e -- 型が変わっちゃうのでLambdaは無視できるはず．... といいつつ自信無．July 24, 2008のnotesを参照. ま，hashには使えるという程度のつもり． fromEnum (f :$ e) = fromEnum f #* fromEnum e fromEnum (X n) = n * 0xdeadbeef fromEnum (Primitive n _) = (-1-n) * 0xdeadbeef m #* c = fromIntegral (hashInt m) + (c `mod` fromIntegral prime) instance Ord Exp where compare (VarE n0) (VarE n1) = n0 `compare` n1 compare (VarE n0) _ = LT compare (ConE n0) (VarE n1) = GT compare (ConE n0) (ConE n1) = n0 `compare` n1 compare (ConE n0) _ = LT compare (AppE _ _) (VarE _) = GT compare (AppE _ _) (ConE _) = GT compare (AppE e0 f0) (AppE e1 f1) = case compare e0 e1 of EQ -> compare f0 f1 c -> c compare (AppE _ _) _ = LT compare a b = show a `compare` show b -- 超遅そう.... instance Read Exp where readsPrec _ str = [(error "ReadS Exp is not implemented yet", str)] type VarLib = Array Int PD.Dynamic -- x 第1引数のplはArray Con Stringなんだけど，もう全部Primitiveを使うことになったので不要． -- exprToTHExp converts CoreLang.CoreExpr into Language.Haskell.TH.Exp exprToTHExp, exprToTHExpLite :: VarLib -> CoreExpr -> Exp exprToTHExp vl e = exprToTHExp' True vl $ lightBeta e exprToTHExpLite vl e = exprToTHExp' False vl $ lightBeta e exprToTHExp' pretty vl e = x2hsx (ord 'a'-1) (ord 'a' -1) e where x2hsx dep fdep (Lambda e) = case x2hsx (dep+1) fdep e of LamE pvars expr -> LamE (pvar:pvars) expr expr -> LamE [pvar] expr where var = mkName [chr (dep+1)] pvar | not pretty || 0 `occursIn` e = VarP var | otherwise = WildP x2hsx dep fdep (FunLambda e) = case x2hsx dep (fdep+1) e of LamE pvars expr -> LamE (pvar:pvars) expr expr -> LamE [pvar] expr where var = mkName ['f',chr (fdep+1)] pvar | not pretty || 0 `funOccursIn` e = VarP var | otherwise = WildP x2hsx dep fdep (X n) = VarE (mkName [chr (dep - n)]) -- X nはX 0, X 1, .... x2hsx dep fdep (FunX n) = VarE (mkName ['f',chr (fdep - n)]) -- X nはX 0, X 1, .... -- x2hsx _ (Qualified con) = VarE (mkName (pl ! con)) x2hsx _ _ (Primitive n _) = case PD.dynExp (vl ! n) of ConE name -> ConE $ mkName $ nameBase name VarE name -> VarE $ mkName $ nameBase name e -> e x2hsx dep fdep (Primitive n _ :$ e0 :$ e1) = let hsx0 = x2hsx dep fdep e0 hsx1 = x2hsx dep fdep e1 in case PD.dynExp (vl!n) of e@(VarE name) | head (nameBase name) `elem` "!@#$%&*+./<=>?\\^|-~" -> InfixE (Just hsx0) (VarE $ mkName $ nameBase name) (Just hsx1) | otherwise -> (VarE (mkName $ nameBase name) `AppE` hsx0) `AppE` hsx1 e@(ConE name) | namestr == ":" -> case hsx1 of ListE hsxs -> ListE (hsx0 : hsxs) ConE n | nameBase n == "[]" -> ListE [hsx0] _ -> InfixE (Just hsx0) (ConE $ mkName ":") (Just hsx1) | head namestr == ':' -> InfixE (Just hsx0) (ConE $ mkName namestr) (Just hsx1) | otherwise -> (ConE (mkName namestr) `AppE` hsx0) `AppE` hsx1 where namestr = nameBase name e -> (e `AppE` hsx0) `AppE` hsx1 x2hsx dep fdep (Y :$ FunLambda e) = case x2hsx dep fdep (FunLambda e) of LamE [WildP] expr -> expr LamE (WildP:pvs) expr -> LamE pvs expr expr -> VarE 'fix `AppE` expr -- This is still necessary because systematic synthesizer still uses Lambda and X even for functions. x2hsx dep fdep (Y :$ Lambda e) = case x2hsx dep fdep (Lambda e) of LamE [WildP] expr -> expr LamE (WildP:pvs) expr -> LamE pvs expr expr -> VarE 'fix `AppE` expr x2hsx dep fdep (e0 :$ e1) = x2hsx dep fdep e0 `AppE` x2hsx dep fdep e1 x2hsx dep fdep (Case ce ts) = CaseE (x2hsx dep fdep ce) (map (tsToMatch dep fdep) ts) -- x2hsx dep fdep (Fix ce n is) = x2hsx dep fdep $ foldl (:$) (Y :$ FunLambda (napply n Lambda ce)) (map X is) -- letを使って書いた方がいい感じになる． x2hsx dep fdep (Fix ce n is) = case x2hsx dep fdep (FunLambda (napply n Lambda ce)) of LamE (WildP:ps) e -> foldl AppE (LamE ps e) $ map (x2hsx dep fdep . X) is -- let のあと caseがある場合にさらにrefactorしてたのだが， -- \a -> let fa (b@0) = 0 -- fa (b@succc) | succc > 0 = GHC.Enum.succ (GHC.Enum.succ (GHC.Enum.succ (fa c))) -- where c = succc - 1 -- in fa a -- みたいなのができてめんどくさい． -- てゆーか，pretty printしすぎると，ExecuteAPIするとき逆に遅そう． LamE (VarP name : ps) (CaseE (VarE n) ms) | VarP n `elem` ps -> LetE [FunD name (map (\(Match p b decls) -> Clause (map (replacePat n p) ps) b decls) ms)] (foldl AppE (VarE name) $ map (x2hsx dep fdep . X) is) LamE (VarP name : ps) e -> LetE [FunD name [Clause ps (NormalB e) []]] (foldl AppE (VarE name) $ map (x2hsx dep fdep . X) is) -- x2hsx dep (FixCase ts) = x2hsx dep (Y :$ Lambda (Lambda (Case (X 0) ts))) x2hsx dep _ (VarName str) = VarE (mkName str) x2hsx _ _ Y = VarE 'fix x2hsx _ _ e = error ("exprToTHExp: converting" ++ show e) replacePat name new (VarP o) | o==name = AsP name new replacePat _ _ old = old tsToMatch dep fdep (ctor, arity, expr) = case PD.dynExp (vl ! ctor) of ConE name -> case x2hsx dep fdep (napply arity Lambda expr) of LamE pvars ex -> case compare (length pvars) arity of LT -> error "too few lambda abstractions in Case...can't happen!" EQ -> Match (mkPat nameb pvars) (NormalB ex) [] GT -> Match (mkPat nameb tk) (NormalB $ LamE dr ex) [] where (tk,dr) = splitAt arity pvars ex -- -- | not pretty && nameb == "[]" -> Match (ConP '[] []) (NormalB ex) [] | otherwise -> Match (ConP (mkName nameb) []) (NormalB ex) [] where nameb = nameBase name mkPat ":" [pv1,pv2] = InfixP pv1 (mkName ":") pv2 mkPat (':':_) [pv1,pv2] = InfixP pv1 (mkName nameb) pv2 mkPat nmb pvs = ConP (mkName nameb) pvs VarE name | nameBase name == "succ" -> case x2hsx (dep+1) fdep expr of -- ここのcaseは最初x2hsx dep $ Lambda exprにしていたのだが，WildPになってしまうとguardできなくなるし，かといってCaseの内側でWildPへの置換をやらないとするとみにくいし，このパターンだけWildPを止めるくらいならLambdaの分を展開した方が早いや，ってことで． ex -> Match (VarP succn) (GuardedB [(NormalG (InfixE (Just $ VarE succn) (VarE $ mkName ">") (Just $ LitE $ IntegerL 0)),ex)]) [ValD (VarP name) (NormalB (InfixE (Just $ VarE succn) (VarE $ mkName "-") (Just $ LitE (IntegerL 1)))) []] where str = [chr (dep+1)] name = mkName str succn = mkName ("succ"++str) | nameBase name == "negate" -> case x2hsx (dep+1) fdep expr of ex -> Match (VarP negn) (GuardedB [(NormalG (InfixE (Just $ VarE negn) (VarE $ mkName "<") (Just $ LitE $ IntegerL 0)),ex)]) [ValD (VarP name) (NormalB ((VarE 'negate) `AppE` (VarE negn))) []] where str = [chr (dep+1)] name = mkName str negn = mkName ("neg"++str) LitE lit -> Match (LitP lit) (NormalB $ x2hsx dep fdep expr) [] e -> error (pprint e ++ " : non-constructor where a constructor is expected.") n `occursIn` Lambda e = succ n `occursIn` e n `occursIn` FunLambda e = n `occursIn` e -- n `occursIn` FixCase ts = any (\(_,a,ce) -> (n+a+2) `occursIn` ce) ts n `occursIn` X m = n==m n `occursIn` (f :$ e) = (n `occursIn` f) || (n `occursIn` e) n `occursIn` Case x ts = n `occursIn` x || any (\(_,a,ce) -> (n+a) `occursIn` ce) ts n `occursIn` Fix e m is = n `elem` is || (n+m) `occursIn` e _ `occursIn` _ = False n `funOccursIn` Lambda e = n `funOccursIn` e n `funOccursIn` FunLambda e = succ n `funOccursIn` e n `funOccursIn` FunX m = n==m n `funOccursIn` (f :$ e) = (n `funOccursIn` f) || (n `funOccursIn` e) n `funOccursIn` Case x ts = n `funOccursIn` x || any (\(_,a,ce) -> n `funOccursIn` ce) ts n `funOccursIn` Fix e _ _ = succ n `funOccursIn` e _ `funOccursIn` _ = False lightBeta :: CoreExpr -> CoreExpr lightBeta (Fix e m is) | 0 `funOccursIn` e = Fix (lightBeta e) m is | otherwise = liftFun 0 $ nlift 0 m $ foldr ($) (lightBeta e) $ zipWith replace [m-1,m-2..0] $ map (m+) is lightBeta (Lambda e) = Lambda $ lightBeta e lightBeta (FunLambda e) = FunLambda $ lightBeta e lightBeta (Lambda e :$ X n) = lightBeta $ nlift 0 1 $ replace 0 n e lightBeta (f :$ e) = lightBeta f :$ lightBeta e lightBeta (Case x ts) = Case (lightBeta x) (map (\(c,a,ce) -> (c,a,lightBeta ce)) ts) lightBeta e = e replace o n e@(X i) | i==o = X n replace o n (Lambda e) = Lambda (replace (succ o) (succ n) e) replace o n (FunLambda e) = FunLambda $ replace o n e replace o n (f :$ e) = replace o n f :$ replace o n e replace o n (Case x ts) = Case (replace o n x) (map (\(c,a,ce) -> (c,a,replace (o+a) (n+a) ce)) ts) replace o n (Fix e m is) = Fix (replace (o+m) (n+m) e) m (map (\x -> if x==o then n else x) is) replace o n e = e liftFun th (FunX i) | th (c,a,liftFun th ce)) ts) liftFun th (Fix e m is) = Fix (liftFun (succ th) e) m is liftFun _ e = e nlift th n (X i) | th (c,a,nlift (th+a) n ce)) ts) nlift th n (Fix e m is) = Fix (nlift (th+m) n e) m (map (nliftInt th n) is) nlift th n e = e nliftInt th n i | th < i = i-n | otherwise = i napply n f x = iterate f x !! n isObviouslyBoring :: Exp -> Bool isObviouslyBoring = iOB [] iOB patss (LamE pats expr) = iOB (reverse pats:patss) expr iOB _ (VarE _) = False iOB _ (ConE _) = False iOB patss (InfixE (Just e1) o (Just e2)) = iOB patss e1 || iOB patss e2 iOB patss (ListE es) = any (iOB patss) es iOB patss (CaseE e ts) = iOB patss e || any iOBMatch ts where iOBMatch (Match _ (NormalB ce) _) = iOB patss ce iOBMatch (Match _ (GuardedB ts) _) = any (iOB patss . snd) ts iOB patss ce@(AppE f e) = any (matchExp ce) patss || iOB patss f || iOB patss e matchExp (AppE f e) (WildP:pats) = matchExp f pats matchExp (AppE f (VarE n1)) (VarP n2:pats) = nameBase n1 == nameBase n2 && matchExp f pats matchExp (VarE n1) [VarP n2] = nameBase n1 == nameBase n2 matchExp _ _ = False -- Another 'Primitive' moved from MagicHaskeller.lhs, which should be renamed in some way.... type Primitive = (HValue, Exp, Type) newtype HValue = HV (forall a. a) primitivesToTCL :: [Primitive] -> TyConLib primitivesToTCL ps = let (_,_,ts) = unzip3 ps in thTypesToTCL ts -- thTypesToTCL encloses defaultTyCons primitivesToVL :: TyConLib -> [Primitive] -> VarLib primitivesToVL tcl ps = listArray (0, length ps + (lenDefaultPrimitives-1)) (map (\ (HV x, e, ty) -> PD.unsafeToDyn tcl (thTypeToType tcl ty) x e) ps ++ defaultPrimitives) -- | 'defaultVarLib' can be used as a VarLib for testing and debugging. Currently this is used only by the analytical synthesizer. defaultVarLib :: VarLib defaultVarLib = listArray (0, lenDefaultPrimitives-1) defaultPrimitives lenDefaultPrimitives = length defaultPrimitives -- | @defaultPrimitives@ is the set of primitives that we want to make sure to appear in VarLib but may not appear in the primitive set with which to synthesize. -- In other words, it is the set of primitives we want to make sure to assign IDs to. defaultPrimitives :: [PD.Dynamic] defaultPrimitives = [ $(PD.dynamic [|defaultTCL|] [|()::()|]), $(PD.dynamic [|defaultTCL|] [|(,) ::a->b->(a,b)|]), $(PD.dynamic [|defaultTCL|] [|(,,) ::a->b->c->(a,b,c)|]), $(PD.dynamic [|defaultTCL|] [|(,,,) ::a->b->c->d->(a,b,c,d)|]), $(PD.dynamic [|defaultTCL|] [|(,,,,) ::a->b->c->d->e->(a,b,c,d,e)|]), $(PD.dynamic [|defaultTCL|] [|(,,,,,) ::a->b->c->d->e->f->(a,b,c,d,e,f)|]), $(PD.dynamic [|defaultTCL|] [|(,,,,,,)::a->b->c->d->e->f->g->(a,b,c,d,e,f,g)|]), $(PD.dynamic [|defaultTCL|] [|Left :: a -> Either a b|]), $(PD.dynamic [|defaultTCL|] [|Right :: b -> Either a b|]), $(PD.dynamic [|defaultTCL|] [|Nothing :: Maybe a|]), $(PD.dynamic [|defaultTCL|] [|Just :: a -> Maybe a|]), $(PD.dynamic [|defaultTCL|] [|LT :: Ordering|]), $(PD.dynamic [|defaultTCL|] [|EQ :: Ordering|]), $(PD.dynamic [|defaultTCL|] [|GT :: Ordering|]), $(PD.dynamic [|defaultTCL|] [|(+)::Int->Int->Int|]), $(PD.dynamic [|defaultTCL|] [|False::Bool|]), $(PD.dynamic [|defaultTCL|] [|True::Bool|]), $(PD.dynamic [|defaultTCL|] [|[]::[a]|]), $(PD.dynamic [|defaultTCL|] [|(:)::a->[a]->[a]|]), $(PD.dynamic [|defaultTCL|] [|0::Int|]), -- What if, e.g., Integer instead of Int is used? $(PD.dynamic [|defaultTCL|] [|succ::Int->Int|]), $(PD.dynamic [|defaultTCL|] [|negate::Int->Int|])] -- succ, viewed as a constructor, can be converted into n+k pattern while postprocessing, but what can I do for negate? -- Maybe I could say @ case x of _ | x<0 -> ... where i = -x @, so I can avoid introducing a new variable. -- ... but then, what if x is not actually a variable? -- ... Uh, n+k pattern can not yet be handled by TH. (Try @runQ [| case 3 of k+1 -> k |] >>= print@ in GHCi.) -- The above are dealt with by CoreLang.exprToTHExp. \end{code}