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

….0.0.1

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