Tweaks in progress. Waiting for conversion to GHC 10.7.3 and HERMIT 1.0.0.1

Author: conal

src/LambdaCCC/Monomorphize.hs

@@ -178,19 +178,29 @@ specializeTyDict' =
  -- const $ all isTyOrDict
 #endif
 
+unTypeMb :: CoreExpr -> Maybe Type
+unTypeMb (Type ty) = Just ty
+unTypeMb _ = Nothing
+
 specializeTyDict :: ReExpr
 specializeTyDict = watchR "specializeTyDict" $
  tryR simplifyAll
  . unfoldPredR okay
  . 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)

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) =

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??

test/TreeTest.hs

@@ -307,48 +307,37 @@ 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
 
 -- main = go "foo" ()
 
 -- 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))