module E.FromHs( convertDecls, convertRules, createInstanceRules, procAllSpecs, getMainFunction ) where import Char import Control.Monad.Identity import Control.Monad.RWS import qualified Data.Traversable as T import Data.Monoid import List(isPrefixOf) import Maybe import Prelude import qualified Data.Map as Map import qualified Text.PrettyPrint.ANSI.Leijen as PPrint import C.FFI import C.Prims as CP import StringTable.Atom import DataConstructors import Doc.DocLike import Doc.PPrint import E.E import E.Eta import E.Eval(eval) import E.LetFloat(atomizeAp) import E.PrimOpt import E.Rules import E.Show(render) import E.Subst import E.Traverse import E.TypeCheck import E.Values import FrontEnd.Class import FrontEnd.Rename(unRename) import FrontEnd.SrcLoc import FrontEnd.Syn.Traverse(getNamesFromHsPat) import FrontEnd.Tc.Main(isTypePlaceholder) import FrontEnd.Tc.Module(TiData(..)) import FrontEnd.Tc.Type hiding(Rule(..)) import FrontEnd.Warning import FrontEnd.HsSyn as HS import Info.Types import Name.Name as Name import Name.Names import Name.VConsts import Options import PackedString import PrimitiveOperators import Support.CanType import Support.FreeVars import Util.Gen import Util.NameMonad import Util.SetLike import qualified FlagOpts as FO import qualified FrontEnd.Tc.Type as T(Rule(..)) import qualified FrontEnd.Tc.Type as Type import qualified Info.Info as Info ump sl e = EError (show sl ++ ": Unmatched pattern") e createIf e a b = do [tv] <- newVars [Unknown] return $ createIfv tv e a b createIfv v e a b = res where tv = v { tvrType = tBoolzh } ic = eCase (EVar tv) [Alt lTruezh a, Alt lFalsezh b] Unknown res = eCase e [Alt (litCons { litName = dc_Boolzh, litArgs = [tv], litType = tBool }) ic] Unknown ifzh e a b = eCase e [Alt lTruezh a, Alt lFalsezh b] Unknown newVars :: UniqueProducer m => [E] -> m [TVr] newVars xs = f xs [] where f [] xs = return $ reverse xs f (x:xs) ys = do s <- newUniq f xs (tVr (2*s) x:ys) tipe t = f t where f (TAp t1 t2) = eAp (f t1) (f t2) f (TArrow t1 t2) = EPi (tVr 0 (f t1)) (f t2) f (TCon (Tycon n k)) | Just n' <- lookup n primitiveAliases = ELit litCons { litName = n', litType = kind k } f (TCon (Tycon n k)) = ELit litCons { litName = n, litType = kind k } f (TVar tv) = EVar (cvar [] tv) f (TMetaVar mv) = cmvar mv f (TForAll vs (ps :=> t)) = foldr EPi (f t) (map (cvar $ freeVars ps) vs) f (TExists xs (_ :=> t)) = let xs' = map (kind . tyvarKind) xs in ELit litCons { litName = unboxedNameTuple TypeConstructor (length xs' + 1), litArgs = f t:xs', litType = eHash } cvar fvs tv@Tyvar { tyvarName = n, tyvarKind = k } | tv `elem` fvs = setProperty prop_SCRUTINIZED (tVr (lt n) (kind k)) | otherwise = tVr (lt n) (kind k) cmvar MetaVar { metaKind = k } = tAbsurd (kind k) lt n | nameType n == TypeVal = toId n -- verifies namespace | otherwise = error "E.FromHs.lt" kind (KBase KUTuple) = eHash kind (KBase KHash) = eHash kind (KBase Star) = eStar kind (KBase KQuest) = eStar -- XXX why do these still exist? kind (KBase KQuestQuest) = eStar kind (Kfun k1 k2) = EPi (tVr 0 (kind k1)) (kind k2) kind (KVar _) = error "Kind variable still existing." kind _ = error "E.FromHs.kind: unknown" simplifyDecl (HsPatBind sl (HsPVar n) rhs wh) = HsFunBind [HsMatch sl n [] rhs wh] simplifyDecl x = x fromTyvar (Tyvar _ n k) = tVr (toId n) (kind k) fromSigma (TForAll vs (_ :=> t)) = (map fromTyvar vs, tipe t) fromSigma t = ([], tipe t) monadicLookup k m = case Map.lookup k m of Just x -> return x Nothing -> fail "key not found" convertValue n = do assumps <- asks ceAssumps dataTable <- asks ceDataTable t <- monadicLookup n assumps let ty = removeNewtypes dataTable (tipe t) cc <- asks ceCoerce lm <- case Map.lookup n cc of Nothing -> do let (vs,_) = fromSigma t return (flip (foldr eLam) vs) Just CTId -> do return id Just ~(CTAbs ts) -> do return $ \e -> foldr eLam e (map fromTyvar ts) return (tVr (toId n) ty,ty,lm) --convertType t = do -- dataTable <- asks ceDataTable -- return $ removeNewtypes dataTable (tipe t) matchesConv ms = map v ms where v (HsMatch _ _ ps rhs wh) = (ps,rhs,wh) altConv as = map v as where v (HsAlt _ p rhs wh) = ([p],rhs,wh) argTypes e = span (sortSortLike . getType) (map tvrType xs) where (_,xs) = fromPi e argTypes' :: E -> ([E],E) argTypes' e = let (x,y) = fromPi e in (map tvrType y,x) getMainFunction :: Monad m => DataTable -> Name -> (Map.Map Name (TVr,E)) -> m (TVr,E) getMainFunction dataTable name ds = do mt <- case Map.lookup name ds of Just x -> return x Nothing -> fail $ "Could not find main function: " ++ show name let funcs = runIdentity $ T.mapM (\n -> return . EVar . fst $ runEither (show n) $ monadicLookup n ds) sFuncNames nameToEntryPoint dataTable (fst mt) (toName Name.Val "theMain") Nothing funcs nameToEntryPoint :: Monad m => DataTable -> TVr -> Name -> Maybe FfiExport -> FuncNames E -> m (TVr,E) nameToEntryPoint dataTable main cname ffi ds = ans where ans = do let runMain = func_runMain ds runExpr = func_runExpr ds runNoWrapper = func_runNoWrapper ds runRaw = func_runRaw ds let e = case extractIO (getType maine) of Just x | not (fopts FO.Wrapper) -> EAp (EAp runNoWrapper x) maine Just x -> EAp (EAp runMain x ) maine Nothing | fopts FO.Raw -> EAp (EAp runRaw ty) maine Nothing -> EAp (EAp runExpr ty) maine ne = ELam worldVar (EAp e (EVar worldVar)) worldVar = tvr { tvrIdent = 2, tvrType = tWorld__ } theMainTvr = tVr (toId cname) (infertype dataTable ne) tvm@(TVr { tvrType = ty}) = main maine = foldl EAp (EVar tvm) [ tAbsurd k | TVr { tvrType = k } <- xs, sortKindLike k ] (_,xs) = fromPi ty return (tvrInfo_u (case ffi of Just ffi -> Info.insert ffi; Nothing -> id) $ setProperty prop_EXPORTED theMainTvr,ne) {-# NOINLINE createInstanceRules #-} createInstanceRules :: DataTable -> ClassHierarchy -> [(TVr,E)] -> Rules createInstanceRules dataTable classHierarchy funcs = fromRules ans where ans = concatMap cClass (classRecords classHierarchy) cClass classRecord = concat [ method classRecord n | (n,TForAll _ (_ :=> t)) <- classAssumps classRecord ] method classRecord methodName | isJust _methodName = as where methodVar = tVr (toId methodName) ty _methodName@(~(Just (TVr {tvrType = ty},_))) = findName methodName defaultName = (defaultInstanceName methodName) valToPat' (ELit LitCons { litAliasFor = af, litName = x, litArgs = ts, litType = t }) = (ELit litCons { litAliasFor = af, litName = x, litArgs = ts', litType = t },ts') where ts' = [ EVar (tVr j (getType z)) | z <- ts | j <- [2,4 ..], j `notElem` map tvrIdent args] --valToPat' (EPi (TVr { tvrType = a}) b) = ELit $ litCons { litName = tc_Arrow, litArgs = [ EVar (tVr j (getType z)) | z <- [a,b] | j <- [2,4 ..], j `notElem` map tvrIdent args], litType = eStar } valToPat' (EPi tv@TVr { tvrType = a} b) = (EPi tvr { tvrType = a'} b',[a',b']) where a' = EVar (tVr ja (getType a)) b' = EVar (tVr jb (getType b)) (ja:jb:_) = [ j | j <- [2,4 ..], j `notElem` map tvrIdent args] valToPat' x = error $ "FromHs.valToPat': " ++ show x as = [ rule t | Inst { instHead = _ :=> IsIn _ t } <- snub (classInsts classRecord) ] (_ft,_:args') = fromPi ty (args,_rargs) = span (sortKindLike . getType) args' rule t = makeRule ("Rule.{" ++ show name ++ "}") (Module (show name),0) RuleSpecialization ruleFvs methodVar (vp:map EVar args) (removeNewtypes dataTable body) where ruleFvs = [ t | ~(EVar t) <- vs] ++ args (vp,vs) = valToPat' (removeNewtypes dataTable $ tipe t) name = (instanceName methodName (getTypeCons t)) --vp@(ELit LitCons { litArgs = vs }) = tpat body = case findName name of Just (n,_) -> foldl EAp (EVar n) (vs ++ map EVar args) Nothing -> case findName defaultName of Just (deftvr,_) | null vs -> foldl EAp (EAp (EVar deftvr) vp) (map EVar args) Just (deftvr,_) -> eLet tv vp $ foldl EAp (EAp (EVar deftvr) (EVar tv)) (map EVar args) where tv = tvr { tvrIdent = head [ n | n <- newIds (freeVars vp)], tvrType = getType vp } Nothing -> foldl EAp (EError ( show methodName ++ ": undefined at type " ++ show (pprint t :: PPrint.Doc)) (eAp ty (fst $ valToPat' (tipe t)))) (map EVar args) method _ _ = [] nfuncs = runIdentity $ do let f d@(v,_) = case fromId (tvrIdent v) of Just n -> return (n,d) Nothing -> fail $ "createInstanceRules: top level var with temporary name " ++ show v xs <- mapM f funcs return (Map.fromList xs) findName name = case Map.lookup name nfuncs of Nothing -> fail $ "Cannot find: " ++ show name Just n -> return n getTypeCons (TCon (Tycon n _)) = n getTypeCons (TAp a _) = getTypeCons a getTypeCons (TArrow {}) = tc_Arrow getTypeCons x = error $ "getTypeCons: " ++ show x unbox :: DataTable -> E -> Int -> (E -> E) -> E unbox dataTable e _vn wtd | getType (getType e) == eHash = wtd e unbox dataTable e vn wtd = eCase e [Alt (litCons { litName = cna, litArgs = [tvra], litType = te }) (wtd (EVar tvra))] Unknown where te = getType e tvra = tVr vn sta Just (cna,sta,ta) = lookupCType' dataTable te createFunc :: UniqueProducer m => DataTable -> [E] -> ([(TVr,String)] -> (E -> E,E)) -> m E createFunc dataTable es ee = do xs <- flip mapM es $ \te -> do res@(_,sta,rt) <- lookupCType' dataTable te [n,n'] <- newVars [te,sta] return (n,(n',rt),res) let tvrs' = [ n' | (_,n',_) <- xs ] tvrs = [ t | (t,_,_) <- xs] (me,innerE) = ee tvrs' eee = me $ foldr esr innerE xs esr (tvr,(tvr',_),(cn,_,_)) e = eCase (EVar tvr) [Alt (litCons { litName = cn, litArgs = [tvr'], litType = te }) e] Unknown where te = getType $ EVar tvr return $ foldr ELam eee tvrs instance GenName String where genNames i = map (('x':) . show) [i..] {-# NOINLINE convertRules #-} convertRules :: Monad m => Module -> TiData -> ClassHierarchy -> Map.Map Name Type -> DataTable -> [HsDecl] -> m Rules convertRules mod tiData classHierarchy assumps dataTable hsDecls = ans where ans = do rawRules <- concatMapM g hsDecls return $ fromRules [ makeRule n (mod,i) (if catalyst then RuleCatalyst else RuleUser) vs head args e2 | (catalyst,n,vs,e1,e2) <- rawRules, let (EVar head,args) = fromAp e1 | i <- [1..] ] g (HsPragmaRules rs) = mapM f rs g _ = return [] f pr = do let ce = convertE tiData classHierarchy assumps dataTable (hsRuleSrcLoc pr) e1 <- ce (hsRuleLeftExpr pr) e2 <- ce (hsRuleRightExpr pr) (ts,cs) <- runNameMT $ do ts <- flip mapM (filter (sortKindLike . getType) $ freeVars e1) $ \tvr -> do --return (tvrIdent tvr,tvr) nn <- newNameFrom (map (:'\'':[]) ['a' ..]) return (tvrIdent tvr,tvr { tvrIdent = toId (toName TypeVal nn) }) cs <- flip mapM [toTVr assumps dataTable (toName Val v) | (v,_) <- hsRuleFreeVars pr ] $ \tvr -> do let ur = show $ unRename $ nameName (toUnqualified $ runIdentity $ fromId (tvrIdent tvr)) nn <- newNameFrom (ur:map (\v -> ur ++ show v) [1 ::Int ..]) return (tvrIdent tvr,tvr { tvrIdent = toId (toName Val nn) }) return (ts,cs) let smt = substMap $ fromList [ (x,EVar y)| (x,y) <- ts ] sma = substMap $ fromList [ (x,EVar y)| (x,y) <- cs' ] cs' = [ (x,(tvrType_u smt y))| (x,y) <- cs ] e2' = deNewtype dataTable $ smt $ sma e2 --e2 <- atomizeAp False dataTable Stats.theStats mainModule e2' let e2 = atomizeAp mempty False dataTable e2' return (hsRuleIsMeta pr,hsRuleString pr,( snds (cs' ++ ts) ),eval $ smt $ sma e1,e2) convertE :: Monad m => TiData -> ClassHierarchy -> Map.Map Name Type -> DataTable -> SrcLoc -> HsExp -> m E convertE tiData classHierarchy assumps dataTable srcLoc exp = do [(_,_,e)] <- convertDecls tiData mempty classHierarchy assumps dataTable [HsPatBind srcLoc (HsPVar sillyName') (HsUnGuardedRhs exp) []] return e v_silly = toName Val ("Lhc@","silly") sillyName' = nameName v_silly data CeEnv = CeEnv { ceAssumps :: Map.Map Name Type, ceCoerce :: Map.Map Name CoerceTerm, ceFuncs :: FuncNames E, ceProps :: IdMap Properties, ceSrcLoc :: SrcLoc, ceDataTable :: DataTable } newtype Ce t a = Ce (RWST CeEnv [Warning] Int t a) deriving(Monad,Functor,MonadTrans,MonadIO,MonadReader CeEnv,MonadState Int) instance Monad t => MonadWarn (Ce t) where addWarning w = Ce $ tell [w] instance Monad t => MonadSrcLoc (Ce t) where getSrcLoc = asks ceSrcLoc instance Monad t => MonadSetSrcLoc (Ce t) where withSrcLoc sl = local (\ce -> ce { ceSrcLoc = sl }) instance Monad m => UniqueProducer (Ce m) where newUniq = do i <- get put $! (i + 1) return i instance Monad m => DataTableMonad (Ce m) where getDataTable = asks ceDataTable applyCoersion :: Monad m => CoerceTerm -> E -> Ce m E applyCoersion CTId e = return e applyCoersion ct e = etaReduce `liftM` f ct e where f CTId e = return e f (CTAp ts) e = return $ foldl eAp e (map tipe ts) f (CTAbs ts) e = return $ foldr eLam e (map fromTyvar ts) f (CTCompose ct1 ct2) e = f ct1 =<< (f ct2 e) f (CTFun CTId) e = return e f (CTFun ct) e = do let EPi TVr { tvrType = ty } _ = getType e [y] <- newVars [ty] fgy <- f ct (EAp e (EVar y)) return (eLam y fgy) -- | return primitive instances associated with class given as argument primitiveInstances :: Name -> [(Name,TVr,E)] primitiveInstances name = [(n,setProperties [prop_INSTANCE,prop_INLINE] $ tVr (toId n) (getType v),v) | (cn,n,v) <- constantMethods, cn == name] {-# NOINLINE convertDecls #-} convertDecls :: Monad m => TiData -> IdMap Properties -> ClassHierarchy -> Map.Map Name Type -> DataTable -> [HsDecl] -> m [(Name,TVr,E)] convertDecls tiData props classHierarchy assumps dataTable hsDecls = liftM fst $ evalRWST ans ceEnv 2 where ceEnv = CeEnv { ceCoerce = tiCoerce tiData, ceAssumps = assumps, ceFuncs = funcs, ceProps = props, ceSrcLoc = bogusASrcLoc, ceDataTable = dataTable } Identity funcs = T.mapM (return . EVar . toTVr assumps dataTable) sFuncNames Ce ans = do nds <- mapM cDecl hsDecls return (map anninst $ concat nds) doNegate e = eAp (eAp (func_negate funcs) (getType e)) e anninst (a,b,c) | "Instance@" `isPrefixOf` show a = (a,setProperty prop_INSTANCE b, deNewtype dataTable c) | otherwise = (a,b, deNewtype dataTable c) marshallToC :: UniqueProducer m => DataTable -> E -> E -> m E marshallToC dataTable e te | otherwise = do (cna,sta,ta) <- lookupCType' dataTable te [tvra] <- newVars [sta] return $ eCase e [Alt (litCons { litName = cna, litArgs = [tvra], litType = te }) (EVar tvra)] Unknown marshallFromC :: UniqueProducer m => DataTable -> E -> E -> m E marshallFromC dataTable ce te | otherwise = do (cna,sta,ta) <- lookupCType' dataTable te return $ ELit (litCons { litName = cna, litArgs = [ce], litType = te }) -- first argument builds the actual call primitive, given -- (a) the C argtypes -- (b) the C return type -- (c) whether it's IO-like or not -- (d) the real return type -- (e) the arguments themselves -- ccallHelper returns a function expression to perform the call, when given the arguments ccallHelper :: Monad m => ([ExtType] -> ExtType -> Bool -> [E] -> E -> E) -> E -> Ce m E ccallHelper myPrim ty = do let (ts,rt) = argTypes' ty (isIO,rt') = extractIO' rt es <- newVars [ t | t <- ts, not (sortKindLike t) ] pt <- lookupCType rt' cts <- mapM lookupCType (filter (not . sortKindLike) ts) [tvrWorld, tvrWorld2] <- newVars [tWorld__,tWorld__] let cFun = createFunc dataTable (map tvrType es) prim = myPrim cts pt case (isIO,pt) of (True,"void") -> cFun $ \rs -> (,) (ELam tvrWorld) $ eStrictLet tvrWorld2 (prim True (EVar tvrWorld :[EVar t | (t,_) <- rs ]) tWorld__) (eJustIO (EVar tvrWorld2) vUnit) (False,"void") -> fail "pure foreign function must return a valid value" _ -> do (cn,rtt',_) <- lookupCType' dataTable rt' [rtVar,rtVar'] <- newVars [rt',rtt'] let rttIO = ltTuple [tWorld__, rt'] rttIO' = ltTuple' [tWorld__, rtt'] case isIO of False -> cFun $ \rs -> (,) id $ eStrictLet rtVar' (prim False [ EVar t | (t,_) <- rs ] rtt') (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' }) True -> cFun $ \rs -> (,) (ELam tvrWorld) $ eCaseTup' (prim True (EVar tvrWorld:[EVar t | (t,_) <- rs ]) rttIO') [tvrWorld2,rtVar'] (eLet rtVar (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' }) (eJustIO (EVar tvrWorld2) (EVar rtVar))) cDecl :: Monad m => HsDecl -> Ce m [(Name,TVr,E)] cDecl (HsForeignDecl _ (FfiSpec (Import cn req) _ Primitive) n _) = do let name = toName Name.Val n (var,ty,lamt) <- convertValue name let (ts,rt) = argTypes' ty prim = APrim (PrimPrim $ toAtom cn) req es <- newVars [ t | t <- ts, not (sortKindLike t) ] let result = foldr ($) (processPrimPrim dataTable $ EPrim prim (map EVar es) rt) (map ELam es) return [(name,setProperty prop_INLINE var,lamt result)] cDecl (HsForeignDecl _ (FfiSpec (ImportAddr rcn req) _ _) n _) = do let name = toName Name.Val n (var,ty,lamt) <- convertValue name let (ts,rt) = argTypes' ty (cn,st,_ct) <- lookupCType' dataTable rt [uvar] <- newVars [st] let expr x = return [(name,setProperty prop_INLINE var,lamt x)] prim = APrim (AddrOf $ packString rcn) req expr $ eStrictLet uvar (EPrim prim [] st) (ELit (litCons { litName = cn, litArgs = [EVar uvar], litType = rt })) cDecl (HsForeignDecl _ (FfiSpec (Import rcn req) _ CCall) n _) = do let name = toName Name.Val n (var,ty,lamt) <- convertValue name result <- ccallHelper (\cts crt io args rt -> EPrim (APrim (Func io (packString rcn) cts crt) req) args rt) ty return [(name,setProperty prop_INLINE var,lamt result)] cDecl (HsForeignDecl _ (FfiSpec Dynamic _ CCall) n _) = do -- XXX ensure that the type is of form FunPtr /ft/ -> /ft/ let name = toName Name.Val n (var,ty,lamt) <- convertValue name let ((fptrTy:_), _) = argTypes' ty fty = discardArgs 1 ty result <- ccallHelper (\cts crt io args rt -> EPrim (APrim (IFunc io (tail cts) crt) (Requires [] [])) args rt) ty return [(name,setProperty prop_INLINE var,lamt result)] cDecl (HsForeignDecl _ (FfiSpec (Import rcn _) _ DotNet) n _) = do (var,ty,lamt) <- convertValue (toName Name.Val n) let (ts,rt) = argTypes' ty (isIO,rt') = extractIO' rt es <- newVars [ t | t <- ts, not (sortKindLike t) ] pt <- lookupCType rt' [tvrWorld, tvrWorld2] <- newVars [tWorld__,tWorld__] dnet <- parseDotNetFFI rcn let cFun = createFunc dataTable (map tvrType es) prim rs rtt = EPrim (APrim dnet { primIOLike = isIO } mempty) result <- case (isIO,pt) of (True,"void") -> cFun $ \rs -> (,) (ELam tvrWorld) $ eStrictLet tvrWorld2 (prim rs "void" (EVar tvrWorld:[EVar t | (t,_) <- rs ]) tWorld__) (eJustIO (EVar tvrWorld2) vUnit) (False,"void") -> fail "pure foreign function must return a valid value" _ -> do (cn,rtt',rtt) <- lookupCType' dataTable rt' [rtVar,rtVar'] <- newVars [rt',rtt'] let rttIO = ltTuple [tWorld__, rt'] rttIO' = ltTuple' [tWorld__, rtt'] case isIO of False -> cFun $ \rs -> (,) id $ eStrictLet rtVar' (prim rs rtt [ EVar t | (t,_) <- rs ] rtt') (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' }) True -> cFun $ \rs -> (,) (ELam tvrWorld) $ eCaseTup' (prim rs rtt (EVar tvrWorld:[EVar t | (t,_) <- rs ]) rttIO') [tvrWorld2,rtVar'] (eLet rtVar (ELit $ litCons { litName = cn, litArgs = [EVar rtVar'], litType = rt' }) (eJustIO (EVar tvrWorld2) (EVar rtVar))) return [(toName Name.Val n,var,lamt result)] cDecl x@HsForeignDecl {} = fail ("Unsupported foreign declaration: "++ show x) cDecl (HsForeignExport _ ffi@(FfiExport ecn _ cc@CCall) n _) = do let name = ffiExportName ffi fn <- convertVar name tn <- convertVar (toName Name.Val n) (var,ty,lamt) <- convertValue name let (argTys,retTy') = argTypes' ty (isIO,retTy) = extractIO' retTy' retCTy <- if retTy == tUnit then return unboxedTyUnit else liftM (\(_, _, x) -> rawType x) $ lookupCType' dataTable retTy argCTys <- liftM (map rawType) (mapM (liftM (\(_,_,x) -> x) . lookupCType' dataTable) argTys) argTvrs <- newVars argCTys argEs <- sequence [(marshallFromC dataTable (EVar v) et) | v <- argTvrs | et <- argTys] fe <- actuallySpecializeE (EVar tn) ty let inner = foldl EAp fe argEs retE <- case isIO of False -> marshallToC dataTable inner retTy True -> do [world_, world__, ret] <- newVars [tWorld__, tWorld__, retTy] retMarshall <- if retTy == tUnit then return (ELit (unboxedTuple [])) else marshallToC dataTable (EVar ret) retTy return (eLam world_ (eCaseTup' (eAp inner (EVar world_)) [world__, ret] (ELit (unboxedTuple [EVar world__, retMarshall])))) let retCTy' = typeInfer dataTable retE -- trace ("retE: "++pprint retE) $ return () let result = foldr ELam retE argTvrs realRetCTy:realArgCTys <- mapM lookupCType (retTy:argTys) return [(name, tvrInfo_u (Info.insert (ffi, (realArgCTys,realRetCTy))) (fmap (const (foldr tFunc retCTy' argCTys)) $ --fmap (const Unknown) $ setProperty prop_EXPORTED fn), result)] cDecl x@HsForeignExport {} = fail ("Unsupported foreign export: "++ show x) cDecl (HsPatBind sl (HsPVar n) (HsUnGuardedRhs exp) []) | n == sillyName' = do e <- cExpr exp return [(v_silly,tvr,e)] cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- p = do let name = toName Name.Val n (var,ty,lamt) <- convertValue name rhs <- cRhs sl rhs lv <- hsLetE wh rhs return [(name,var,lamt lv)] cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- p = do let name = toName Name.Val n (var,ty,lamt) <- convertValue name rhs <- cRhs sl rhs lv <- hsLetE wh rhs return [(name,var,lamt lv)] cDecl (HsPatBind sl p rhs wh) | (HsPVar n) <- p = do let name = toName Name.Val n (var,ty,lamt) <- convertValue name rhs <- cRhs sl rhs lv <- hsLetE wh rhs return [(name,var,lamt lv)] cDecl (HsFunBind [(HsMatch sl n ps rhs wh)]) | all isHsPVar ps = do let name = toName Name.Val n (var,ty,lamt) <- convertValue name rhs <- cRhs sl rhs lv <- hsLetE wh rhs lps <- lp ps lv return [(name,var,lamt lps )] cDecl (HsFunBind ms@((HsMatch sl n ps _ _):_)) = do let name = toName Name.Val n (var,t,lamt) <- convertValue name let (targs,eargs) = argTypes t numberPatterns = length ps bs' <- newVars (take numberPatterns eargs) let bs = map EVar bs' rt = discardArgs (length targs + numberPatterns) t z e = foldr eLam e bs' ms <- cMatchs bs (matchesConv ms) (ump sl rt) return [(name,var,lamt $ z ms )] cDecl HsNewTypeDecl { hsDeclName = dname, hsDeclArgs = dargs, hsDeclCon = dcon, hsDeclDerives = derives } = return $ makeDerives dname dargs [dcon] (map (toName ClassName) derives) cDecl HsDataDecl { hsDeclName = dname, hsDeclArgs = dargs, hsDeclCons = dcons, hsDeclDerives = derives } = return $ makeDerives dname dargs dcons (map (toName ClassName) derives) cDecl cd@(HsClassDecl {}) = cClassDecl cd cDecl _ = return [] makeDerives dname dargs dcons derives = concatMap f derives where f n | n == class_Bounded, all (null . hsConDeclArgs) dcons = [] f _ = [] cExpr :: Monad m => HsExp -> Ce m E cExpr (HsAsPat n' (HsCon n)) = return $ constructionExpression dataTable (toName DataConstructor n) rt where t' = getAssump n' (_,rt) = argTypes' (tipe t') cExpr (HsLit (HsStringPrim s)) = return $ EPrim (APrim (PrimString (packString s)) mempty) [] (rawType "bits") cExpr (HsLit (HsString s)) = return $ E.Values.toE s cExpr (HsAsPat n' (HsLit (HsIntPrim i))) = ans where t' = getAssump n' ans = return $ ELit (LitInt (fromIntegral i) (tipe t')) cExpr (HsAsPat n' (HsLit (HsInt i))) = ans where t' = getAssump n' ty = tipe t' ans = case lookupCType' dataTable ty of Just (cn,st,_it) -> return $ ELit (litCons { litName = cn, litArgs = [ELit (LitInt (fromIntegral i) st)], litType = ty }) Nothing -> return $ intConvert' funcs ty i --Just (cn,st,it) -> --cExpr (HsLit (HsInt i)) = return $ intConvert i cExpr (HsLit (HsChar ch)) = return $ toE ch cExpr (HsLit (HsFrac i)) = return $ toE i cExpr (HsLambda sl ps e) | all isHsPVar ps = do e <- cExpr e lp ps e cExpr (HsInfixApp e1 v e2) = do v <- cExpr v e1 <- cExpr e1 e2 <- cExpr e2 return $ eAp (eAp v e1) e2 cExpr (HsLeftSection op e) = liftM2 eAp (cExpr op) (cExpr e) cExpr (HsApp (HsRightSection e op) e') = do op <- cExpr op e' <- cExpr e' e <- cExpr e return $ eAp (eAp op e') e cExpr (HsRightSection e op) = do cop <- cExpr op ce <- cExpr e let (_,TVr { tvrType = ty}:_) = fromPi (getType cop) [var] <- newVars [ty] return $ eLam var (eAp (eAp cop (EVar var)) ce) cExpr (HsApp e1 e2) = liftM2 eAp (cExpr e1) (cExpr e2) cExpr (HsParen e) = cExpr e cExpr (HsExpTypeSig _ e _) = cExpr e cExpr (HsNegApp e) = liftM doNegate (cExpr e) cExpr (HsLet dl e) = hsLet dl e cExpr (HsIf e a b) = join $ liftM3 createIf (cExpr e) (cExpr a) (cExpr b) cExpr (HsCase _ []) = error "empty case" cExpr (HsAsPat n HsError { hsExpString = msg }) = do ty <- convertTyp (toName Name.Val n) return $ EError msg ty cExpr (HsAsPat n hs@(HsCase e alts)) = do ty <- convertTyp (toName Name.Val n) scrut <- cExpr e cMatchs [scrut] (altConv alts) (EError ("No Match in Case expression at " ++ show (srcLoc hs)) ty) cExpr (HsTuple es) = liftM eTuple (mapM cExpr es) cExpr (HsUnboxedTuple es) = liftM eTuple' (mapM cExpr es) cExpr (HsAsPat n (HsList xs)) = do ty <- convertTyp (toName Name.Val n) let cl (x:xs) = liftM2 eCons (cExpr x) (cl xs) cl [] = return $ eNil ty cl xs cExpr (HsVar n) = do t <- convertVar (toName Name.Val n) return (EVar t) cExpr (HsAsPat n' e) = do e <- cExpr e cc <- asks ceCoerce case Map.lookup (toName Val n') cc of Nothing -> return e Just c -> applyCoersion c e cExpr e = fail ("Cannot convert: " ++ show e) hsLetE [] e = return e hsLetE dl e = do nds <- mconcatMapM cDecl dl return $ eLetRec [ (b,c) | (_,b,c) <- nds] e hsLet dl e = do e <- cExpr e hsLetE dl e cMatchs :: Monad m => [E] -> [([HsPat],HsRhs,[HsDecl])] -> E -> Ce m E cMatchs bs ms els = do pg <- processGuards ms convertMatches bs pg els cGuard (HsUnGuardedRhs e) = liftM const $ cExpr e cGuard (HsGuardedRhss (HsGuardedRhs _ g e:gs)) = do g <- cExpr g e <- cExpr e fg <- cGuard (HsGuardedRhss gs) [nv] <- newVars [Unknown] return (\els -> createIfv nv g e (fg els)) cGuard (HsGuardedRhss []) = return id getAssump n = case Map.lookup (toName Name.Val n) assumps of Just z -> z Nothing -> error $ "Lookup failed: " ++ (show n) lp [] e = return e lp (HsPVar n:ps) e = do v <- convertVar (toName Name.Val n) eLam v `liftM` lp ps e lp p e = error $ "unsupported pattern:" <+> tshow p <+> tshow e cRhs sl (HsUnGuardedRhs e) = cExpr e cRhs sl (HsGuardedRhss []) = error "HsGuardedRhss: empty" cRhs sl (HsGuardedRhss gs@(HsGuardedRhs _ _ e:_)) = f gs where f (HsGuardedRhs _ g e:gs) = join $ liftM3 createIf (cExpr g) (cExpr e) (f gs) f [] = do e <- cExpr e return $ ump sl $ getType e processGuards xs = flip mapM xs $ \ (ps,e,wh) -> do cg <- cGuard e nds <- mconcatMapM cDecl wh let elet = eLetRec [ (b,c) | (_,b,c) <- nds] return (ps,elet . cg ) cClassDecl (HsClassDecl _ (HsQualType _ (HsTyApp (HsTyCon name) _)) decls) = do props <- asks ceProps let ds = map simplifyDecl decls cr = findClassRecord classHierarchy className className = (toName ClassName name) cClass classRecord = [ f n (toId n) (removeNewtypes dataTable $ tipe t) | (n,t) <- classAssumps classRecord ] where f n i t = (n,setProperties [prop_METHOD,prop_PLACEHOLDER] $ tVr i t, foldr ELam (EPrim (primPrim ("Placeholder: " ++ show n)) [] ft) args) where (ft',as) = fromPi t (args,rargs) = case mlookup i props of Just p | getProperty prop_NOETA p -> span (sortKindLike . getType) as _ -> (as,[]) ft = foldr EPi ft' rargs return (cClass cr ++ primitiveInstances className) cClassDecl _ = error "cClassDecl" convertVar n = do (t,_,_) <- convertValue n return t convertTyp n = do (_,t,_) <- convertValue n return t toTVr assumps dataTable n = tVr (toId n) typeOfName where typeOfName = case Map.lookup n assumps of Just z -> removeNewtypes dataTable (tipe z) Nothing -> error $ "convertVal.Lookup failed: " ++ (show n) integer_cutoff = 500000000 intConvert i | abs i > integer_cutoff = ELit (litCons { litName = dc_Integer, litArgs = [ELit $ LitInt (fromInteger i) (rawType "bits")], litType = tInteger }) intConvert i = ELit (litCons { litName = dc_Int, litArgs = [ELit $ LitInt (fromInteger i) (rawType "bits32")], litType = tInt }) intConvert' funcs typ i = EAp (EAp fun typ) (ELit (litCons { litName = con, litArgs = [ELit $ LitInt (fromInteger i) (rawType rawtyp)], litType = ltype })) where (con,ltype,fun,rawtyp) = case abs i > integer_cutoff of True -> (dc_Integer,tInteger,f_fromInteger,"bits") False -> (dc_Int,tInt,f_fromInt,"bits32") f_fromInt = func_fromInt funcs f_fromInteger = func_fromInteger funcs litconvert (HsChar i) t | t == tChar = LitInt (fromIntegral $ ord i) tCharzh litconvert (HsCharPrim i) t | t == tCharzh = LitInt (fromIntegral $ ord i) tCharzh litconvert (HsIntPrim i) t = LitInt (fromIntegral $ i) t litconvert e t = error $ "litconvert: shouldn't happen: " ++ show (e,t) fromHsPLitInt (HsPLit l@(HsInt _)) = return l fromHsPLitInt (HsPLit l@(HsFrac _)) = return l fromHsPLitInt x = fail $ "fromHsPLitInt: " ++ show x patVar :: Monad m => HsPat -- ^ the pattern -> E -- ^ the type of the expression -> Ce m (HsPat,TVr) -- ^ a new pattern and a binding variable patVar HsPWildCard t = return (HsPWildCard,tvr { tvrType = t }) patVar (HsPVar n) t | isTypePlaceholder n = return (HsPWildCard,tvr { tvrType = t }) patVar (HsPAsPat n p) t | not (isTypePlaceholder n) = do nn <- convertVar (toName Name.Val n) return (p,nn) patVar (HsPAsPat n p) t | isTypePlaceholder n = patVar p t patVar p t = do [nv] <- newVars [t] return (p,nv) tidyPat :: Monad m => HsPat -> E -> Ce m (HsPat,E -> E) tidyPat p b = f p where f HsPWildCard = return (HsPWildCard,id) f (HsPVar n) | isTypePlaceholder n = return (HsPWildCard,id) f (HsPAsPat n p) | isTypePlaceholder n = f p f (HsPTypeSig _ p _) = f p f p@HsPLit {} = return (p,id) f (HsPVar n) = do v <- convertVar (toName Name.Val n) return (HsPWildCard,if EVar v /= b then eLet v b else id) f (HsPAsPat n p) = do (p',g') <- f p v <- convertVar (toName Name.Val n) return (p',(if EVar v /= b then eLet v b else id) . g') f pa@(HsPApp n [p]) = do dataTable <- getDataTable patCons <- getConstructor (toName DataConstructor n) dataTable case conAlias patCons of ErasedAlias -> f p _ -> return (pa,id) f p@HsPApp {} = return (p,id) f ~(HsPIrrPat (Located ss p)) = f p >>= \ (p',fe) -> case p' of HsPWildCard -> return (p',fe) _ -> do (lbv,bv) <- varify b let f n = do v <- convertVar (toName Name.Val n) fe <- convertMatches [bv] [([p],const (EVar v))] (EError (show ss ++ ": Irrefutable pattern match failed") (getType v)) return (v,fe) zs <- mapM f (getNamesFromHsPat p) return (HsPWildCard,lbv . eLetRec zs) -- converts a value to an updatable closure if it isn't one already. varify b@EVar {} = return (id,b) varify b = do [bv] <- newVars [getType b] return (eLet bv b,EVar bv) tidyHeads :: Monad m => E -> [([HsPat],E->E)] -- [(pats,else -> value)] -> Ce m [(HsPat,[HsPat],E->E)] -- pulls the head off of each pattern, tidying it up perhaps tidyHeads b ps = mapM f ps where f (~(p:ps),fe) = do (p',fe') <- tidyPat p b return (p',ps,fe' . fe) convertMatches :: Monad m => [E] -- input expressions we are matching against. -> [([HsPat],E->E)] -- [(pats,else -> value)] -> E -- else, what to do if nothing matches -> Ce m E convertMatches bs ms err = do assumps <- asks ceAssumps dataTable <- getDataTable funcs <- asks ceFuncs let fromInt = func_fromInt funcs fromInteger = func_fromInteger funcs fromRational = func_fromRational funcs isJoinPoint (EAp (EVar x) _) | getProperty prop_JOINPOINT x = True isJoinPoint _ = False match :: Monad m => [E] -> [([HsPat],E->E)] -> E -> Ce m E -- when we run out of arguments, we should run out of patterns. simply fold the transformers. match [] ps err = return $ foldr f err ps where f ([],fe) err = fe err -- when we are out of patterns, return the error term match _ [] err = return err match ~(b:bs) ps err = do (b',mf) <- if isEVar b then return (b,id) else do [ev] <- newVars [getType b] return $ (EVar ev, eLet ev b) pps <- tidyHeads b' ps let patternGroups = groupUnder (isHsPWildCard . fst3) pps f [] err = return err f (ps:pss) err = do err' <- f pss err if isEVar err' || isEError err' || isJoinPoint err' then matchGroup b' bs ps err' else do [ev] <- newVars [EPi tvr { tvrType = unboxedTyUnit } $ getType err'] let ev' = setProperties [prop_ONESHOT, prop_JOINPOINT] ev nm <- matchGroup b' bs ps (EAp (EVar ev') unboxedUnit) return $ eLetRec [(ev',ELam (setProperty prop_ONESHOT tvr { tvrType = unboxedTyUnit }) err')] nm liftM mf $ f patternGroups err matchGroup b bs ps err | all (isHsPWildCard . fst3) ps = match bs [ (ps,e) | (_,ps,e) <- ps] err | Just () <- mapM_ (fromHsPLitInt . fst3) ps = do let tb = getType b (lbv,bv) <- varify b let gps = [ (p,[ (ps,e) | (_,ps,e) <- xs ]) | (p,xs) <- sortGroupUnderF fst3 ps] eq = EAp (func_equals funcs) tb f els (HsPLit (HsInt i),ps) = do let ip | abs i > integer_cutoff = (EAp (EAp fromInteger tb) (intConvert i)) | otherwise = (EAp (EAp fromInt tb) (intConvert i)) m <- match bs ps err createIf (EAp (EAp eq bv) ip) m els f els ~(HsPLit (HsFrac i),ps) = do let ip = (EAp (EAp fromRational tb) (toE i)) m <- match bs ps err createIf (EAp (EAp eq bv) ip) m els e <- foldlM f err gps return $ lbv e | all (isHsPString . fst3) ps = do (lbv,bv) <- varify b (eqString,_,_) <- convertValue v_eqString (eqUnpackedString,_,_) <- convertValue v_eqUnpackedString let gps = [ (p,[ (ps,fe) | (_,ps,fe) <- xs ]) | (p,xs) <- sortGroupUnderF fst3 ps] f els (HsPLit (HsString ""),ps) = do m <- match bs ps err return $ eCase bv [Alt (litCons { litName = dc_EmptyList, litType = tString }) m] els f els ~(HsPLit (HsString s),ps) = do m <- match bs ps err let (s',packed) = packupString s if packed then return $ ifzh (EAp (EAp (EVar eqUnpackedString) s') bv) m els else return $ ifzh (EAp (EAp (EVar eqString) s') bv) m els e <- foldlM f err gps return $ lbv e | all (isHsPLit . fst3) ps = do let gps = [ (p,[ (ps,fe) | (_,ps,fe) <- xs ]) | (p,xs) <- sortGroupUnderF fst3 ps] f (~(HsPLit l),ps) = do m <- match bs ps err return (Alt (litconvert l (getType b)) m) as@(_:_) <- mapM f gps [TVr { tvrIdent = vr }] <- newVars [Unknown] return $ unbox dataTable b vr $ \tvr -> eCase tvr as err | Just ps <- mapM pappConvert ps = do let gps = sortGroupUnderF (hsPatName . fst3) ps (Just patCons) = getConstructor (toName DataConstructor $ fst $ head gps) dataTable f (name,ps) = do let spats = hsPatPats $ fst3 (head ps) nargs = length spats vs <- newVars (slotTypesHs dataTable (toName DataConstructor name) (getType b)) ps' <- mapM pp ps m <- match (map EVar vs ++ bs) ps' err deconstructionExpression dataTable (toName DataConstructor name) (getType b) vs m pp (~(HsPApp n ps),rps,e) = do return $ (ps ++ rps , e) as@(_:_) <- mapM f gps case conVirtual patCons of Nothing -> return $ eCase b as err Just sibs -> do let (Just Constructor { conChildren = DataNormal [vCons] }) = getConstructor (conInhabits patCons) dataTable (Just Constructor { conOrigSlots = [SlotNormal rtype] }) = getConstructor vCons dataTable [z] <- newVars [rtype] let err' = if length sibs <= length as then Unknown else err return $ eCase b [Alt litCons { litName = vCons, litArgs = [z], litType = getType b } (eCase (EVar z) as err')] Unknown | otherwise = error $ "Heterogenious list: " ++ show (map fst3 ps) pappConvert (p@HsPApp {},x,y) = return (p,x,y) pappConvert (HsPLit (HsString ""),ps,b) = return (HsPApp (nameName $ dc_EmptyList) [],ps,b) pappConvert (HsPLit (HsString (c:cs)),ps,b) = return (HsPApp (nameName $ dc_Cons) [HsPLit (HsChar c),HsPLit (HsString cs)],ps,b) pappConvert _ = fail "pappConvert" isHsPString (HsPLit HsString {}) = True isHsPString _ = False match bs ms err packupString :: String -> (E,Bool) packupString s | all (\c -> c > '\NUL' && c <= '\xff') s = (EPrim (APrim (PrimString (packString s)) mempty) [] (rawType "bits"),True) packupString s = (toE s,False) actuallySpecializeE :: Monad m => E -- ^ the general expression -> E -- ^ the specific type -> m E -- ^ the specialized value actuallySpecializeE ge st = do -- trace (pprint (ge, getType ge, st)) $ return () liftM (foldl EAp ge) (specializeE (getType ge) st) specializeE :: Monad m => E -- ^ the general type -> E -- ^ the specific type -> m [E] -- ^ what to apply the general type to to get the specific one specializeE gt st = do let f zs x | Just mm <- match (const Nothing) zs x st = mapM (g mm) (reverse zs) where g mm tvr = case lookup tvr mm of Just x -> return x Nothing -> fail $ "specializeE: variable not bound: " ++ pprint (((gt,st),(mm,tvr)),(zs,x)) f zs (EPi vbind exp) = f (vbind:zs) exp f _ _ = fail $ render (text "specializeE: attempt to specialize types that do not unify:" <$> pprint (gt,st) <$> tshow gt <$> tshow st) f [] gt procAllSpecs :: Monad m => [Type.Rule] -> [(TVr,E)] -> m ([(TVr,E)],Rules) procAllSpecs rs ds = do let specMap = Map.fromListWith (++) [ (toId n,[r]) | r@Type.RuleSpec { Type.ruleName = n } <- rs] f (t,e) | Just rs <- Map.lookup (tvrIdent t) specMap = do hs <- mapM (makeSpec (t,e)) rs return (unzip hs) f _ = return mempty (nds,rules) <- mconcat `liftM` mapM f ds return $ (nds,fromRules rules) makeSpec :: Monad m => (TVr,E) -> T.Rule -> m ((TVr,E),Rule) makeSpec (t,e) T.RuleSpec { T.ruleType = rt, T.ruleUniq = (Module m,ui), T.ruleSuper = ss } = do let nt = tipe rt as <- specializeE (getType t) nt let ntvr = tvr { tvrIdent = toId newName, tvrType = nt, tvrInfo = setProperties (prop_SPECIALIZATION:sspec) mempty } Just nn = fromId (tvrIdent t) (ntype,Just m,q) = nameParts nn newName = toName ntype (Just $ "Spec@." ++ m ++ "." ++ show ui,'f':m ++ "." ++ q) sspec = if ss then [prop_SUPERSPECIALIZE] else [] ar = makeRule ("Specialize.{" ++ show newName) (Module m,ui) RuleSpecialization [] t as (EVar ntvr) return ((ntvr,foldl EAp e as),ar) deNewtype :: DataTable -> E -> E deNewtype dataTable e = removeNewtypes dataTable (f e) where f ECase { eCaseScrutinee = e, eCaseAlts = ((Alt (LitCons { litName = n, litArgs = [v], litType = t }) z):_) } | alias == ErasedAlias = f (eLet v e z) where Identity Constructor { conAlias = alias } = getConstructor n dataTable f ECase { eCaseScrutinee = e, eCaseAlts = ((Alt (LitCons { litName = n, litArgs = [v], litType = t }) z):_) } | alias == RecursiveAlias = f $ eLet v (prim_unsafeCoerce e (getType v)) z where Identity Constructor { conAlias = alias } = getConstructor n dataTable f e = runIdentity $ emapE (return . f) e