From 141a713456d447d27dbe440fa27a9372cd44dc7f Mon Sep 17 00:00:00 2001 From: Conal Elliott Date: Fri, 11 Dec 2015 19:17:15 -0800 Subject: [PATCH] Tweaks in progress. Waiting for conversion to GHC 10.7.3 and HERMIT 1.0.0.1 --- src/LambdaCCC/Monomorphize.hs | 22 ++++++++++++--- src/LambdaCCC/ReifySimple.hs | 13 ++++++--- test/DoTreeNoReify.hss | 2 +- test/TreeTest.hs | 53 ++++++++++++++--------------------- 4 files changed, 49 insertions(+), 41 deletions(-) diff --git a/src/LambdaCCC/Monomorphize.hs b/src/LambdaCCC/Monomorphize.hs index 489bda8..6d777b0 100644 --- a/src/LambdaCCC/Monomorphize.hs +++ b/src/LambdaCCC/Monomorphize.hs @@ -178,6 +178,10 @@ specializeTyDict' = -- const $ all isTyOrDict #endif +unTypeMb :: CoreExpr -> Maybe Type +unTypeMb (Type ty) = Just ty +unTypeMb _ = Nothing + specializeTyDict :: ReExpr specializeTyDict = watchR "specializeTyDict" $ tryR simplifyAll @@ -185,12 +189,18 @@ specializeTyDict = watchR "specializeTyDict" $ . rejectR (dictResultTy . exprType') . rejectR isType where - okay v [Type ty] = not (isPrimOrRepMeth v ty) + -- Arguments are all types, and function/method is not a prim or repr/abst. + okay v (mapM unTypeMb -> Just tys) = isGlobalId v && -- EXPERIMENTAL. See below. + not (isPrimOrRepMeth v tys) + -- okay v [Type ty] = not (isPrimOrRepMeth v [ty]) -- not (isRepMeth v || (isPrimitiveOp v && isPrimitiveTy ty)) -- what's this one for? If I use it, take care with repr/abst -- okay v [] = isGlobalId v okay _ _ = False +-- TODO: revisit the isGlobalId test. I don't think it's really what I'm looking +-- for. Sometimes GHC moves code out of the 'reifyEP' call but still local. +-- Also, what about local polymorphic definitions? #if 1 dictResultTy :: Type -> Bool @@ -372,9 +382,13 @@ letFloatArgNoDelayR = unlessM (isDelayLet <$> id) letFloatArgR caseDefaultR :: ReExpr caseDefaultR = do Case scrut wild _ [(_,[],body)] <- id - return $ case idOccInfo wild of - IAmDead -> body - _ -> Let (NonRec wild scrut) body + case idOccInfo wild of + IAmDead -> return body + _ -> +-- do guardMsg (not (isUnLiftedType (exprType scrut))) +-- "caseDefaultR: unlifted type" + return (Let (NonRec wild scrut) body) + retypeProgR :: ReProg retypeProgR = progRhsAnyR ({-bracketR "retypeExprR"-} retypeExprR) diff --git a/src/LambdaCCC/ReifySimple.hs b/src/LambdaCCC/ReifySimple.hs index 5817d7d..e7297fb 100644 --- a/src/LambdaCCC/ReifySimple.hs +++ b/src/LambdaCCC/ReifySimple.hs @@ -134,8 +134,13 @@ unEval = unCallE1 evalS reifyEval :: ReExpr reifyEval = unReify >>> unEval +-- Generate a reify call. Fail on dictionaries. reifyOf :: CoreExpr -> TransformU CoreExpr -reifyOf e = appsE reifyS [exprType' e] [e] +reifyOf e = do guardMsg (not (isDictTy (exprType' e))) + "reifyOf: Given a type expr." + appsE reifyS [exprType' e] [e] + +-- reifyOf e = appsE reifyS [exprType' e] [e] evalOf :: CoreExpr -> TransformU CoreExpr evalOf e = appsE evalS [dropEP (exprType' e)] [e] @@ -467,9 +472,9 @@ isPrimitiveName name = || name `M.member` stdMeths -- || isRepMeth name -isPrimOrRepMeth :: Var -> Type -> Bool -isPrimOrRepMeth (fqVarName -> name) ty = - isRepMeth name || (isPrimitiveName name && isPrimitiveTy ty) +isPrimOrRepMeth :: Var -> [Type] -> Bool +isPrimOrRepMeth (fqVarName -> name) tys = + isRepMeth name || (isPrimitiveName name && all isPrimitiveTy tys) isPrimitiveOp :: Var -> Bool isPrimitiveOp (fqVarName -> name) = diff --git a/test/DoTreeNoReify.hss b/test/DoTreeNoReify.hss index ee2f677..3e0b876 100644 --- a/test/DoTreeNoReify.hss +++ b/test/DoTreeNoReify.hss @@ -10,7 +10,7 @@ set-pp-coercion Kind binding-of 'main -- Marked INLINE in LambdaCCC.Run, but still needs explicit unfolding here: -try (any-td (unfold ['go,'go','goM,'goM','goMSep,'reifyMealy,'goNew,'goNew'])) +try (any-td (unfold ['go,'go','goSep,'goM,'goM','goMSep,'reifyMealy,'goNew,'goNew'])) down ; try simplifyAll' ; up -- Necessary?? diff --git a/test/TreeTest.hs b/test/TreeTest.hs index 43e29f8..00cb8e1 100644 --- a/test/TreeTest.hs +++ b/test/TreeTest.hs @@ -307,28 +307,7 @@ do2 = inTest "hermit TreeTest.hs -v0 -opt=LambdaCCC.Monomorphize DoTree.hss" -- Only works when compiled with HERMIT main :: IO () -#if 0 --------- Dave's FFT stuff ---------------------------------------------- --- Phasor, as a function of tree depth. -phasor :: (IsNat n, RealFloat a, Enum a) => Nat n -> RTree n (Complex a) -phasor n = scanlTEx (*) 1 (pure phaseDelta) - where phaseDelta = cis ((-pi) / 2 ** natToZ n) - --- Radix-2, DIT FFT -fft_r2_dit :: (IsNat n, RealFloat a, Enum a) => RTree n (Complex a) -> RTree n (Complex a) -fft_r2_dit = fft_r2_dit' nat - -fft_r2_dit' :: (RealFloat a, Enum a) => Nat n -> RTree n (Complex a) -> RTree n (Complex a) -fft_r2_dit' Zero = id -fft_r2_dit' (Succ n) = RT.toB . P.inP (uncurry (+) &&& uncurry (-)) . P.secondP (liftA2 (*) (phasor n)) . fmap (fft_r2_dit' n) . RT.bottomSplit - --- main = go "fft_r2_dit" (fft_r2_dit :: RTree N1 (Complex Int) -> RTree N1 (Complex Int)) --- main = go "fft_r2_dit" (fft_r2_dit :: RTree N2 (Complex Double) -> RTree N2 (Complex Double)) --- main = go "fft_r2_dit" (fft_r2_dit :: RTree N1 (Complex PrettyDouble) -> RTree N1 (Complex PrettyDouble)) --- main = go "fft_r2_dit" (fft_r2_dit :: RTree N2 (Complex Int) -> RTree N2 (Complex Int)) --- main = goSep "fft_r2_dit" 1 (fft_r2_dit :: RTree N1 (Complex Int) -> RTree N1 (Complex Int)) --------- End Dave's FFT stuff ------------------------------------------ -#else +---- FFT type C = Complex Double @@ -336,19 +315,29 @@ type C = Complex Double -- main = go "fft-p" (fft :: Unop (Pair C)) --- main = go "fft-lt0" (fft :: LTree N0 C -> RTree N0 C) - --- main = go "fft-lt2" (fft :: LTree N2 C -> RTree N2 C) +-- main = go "fft-lt1" (fft :: LTree N1 C -> RTree N1 C) -- main = go "fft-rt1" (fft :: RTree N1 C -> LTree N1 C) -- twiddles :: forall g f a. (AFS g, AFS f, RealFloat a) => g (f (Complex a)) --- main = go "twiddles-rt1p" (twiddles :: RTree N1 (Pair C)) +-- main = go "twiddles-lt1p" (twiddles :: LTree N1 (Pair C)) + +-- main = go "foo" (omega (size (undefined :: (LTree N1 :. Pair) ()))) + +-- twiddles :: forall g f a. (AFS g, AFS f, RealFloat a) => g (f (Complex a)) +-- twiddles = powers <$> powers (omega (tySize(g :. f))) -main = go "foo" (size (undefined :: RTree N1 ())) +main = go "foo" (powers :: Int -> LTree N1 Int) --- main = go "foo" (size (undefined :: (RTree N1 :. Pair) ())) +-- zoop :: Int +-- zoop = 3 + +-- main = go "foo" zoop + +-- main = go "foo" (size (undefined :: RTree N3 ())) + +-- main = go "foo" (size (undefined :: (LTree N3 :. Pair) ())) -- main = go "foo" (size (undefined :: Pair ())) @@ -377,13 +366,13 @@ main = go "foo" (size (undefined :: RTree N1 ())) -- main = go "foo" (exp :: Double -> Double) -#endif +---- End FFT -- main = go "map-not-v5" (fmap not :: Vec N5 Bool -> Vec N5 Bool) -- main = go "map-square-v5" (fmap square :: Vec N5 Int -> Vec N5 Int) --- main = go "map-t3" (fmap not :: Unop (RTree N3 Bool)) +-- main = go "map-rt3" (fmap not :: Unop (RTree N3 Bool)) -- main = go "tdott-2" (dot''' :: Pair (RTree N2 Int) -> Int) @@ -439,10 +428,10 @@ main = go "foo" (size (undefined :: RTree N1 ())) -- main = go "test" (dot :: RTree N4 (Int,Int) -> Int) -- -- Ranksep: rt1=0.5, rt2=1, rt3=2, rt4=4,rt5=8 --- main = goSep "transpose-pt4" 4 (transpose :: Pair (RTree N4 Bool) -> RTree N4 (Pair Bool)) +-- main = goSep "transpose-prt4" 4 (transpose :: Pair (RTree N4 Bool) -> RTree N4 (Pair Bool)) -- -- Ranksep: rt1=0.5, rt2=1, rt3=2, rt4=4,rt5=8 --- main = goSep "transpose-t4p" 4 (transpose :: RTree N4 (Pair Bool) -> Pair (RTree N4 Bool)) +-- main = goSep "transpose-rt2p" 1 (transpose :: RTree N2 (Pair Bool) -> Pair (RTree N2 Bool)) -- -- Ranksep: rt1=1, rt2=2, rt3=4, rt4=8, rt5=16 -- main = goSep "transpose-v3t5" 16 (transpose :: Vec N3 (RTree N5 Bool) -> RTree N5 (Vec N3 Bool))