git.iko.soy/Idris-dev
on 0ea1b72 help sign in
Idris-dev/src/IRTS/Compiler.hs
670 lines 25 kB history raw
1{-|
2Module : IRTS.Compiler
3Description : Coordinates the compilation process.
4Copyright :
5License : BSD3
6Maintainer : The Idris Community.
7-}
8{-# LANGUAGE PatternGuards, TypeSynonymInstances, CPP #-}
10module IRTS.Compiler(compile, generate) where
12import IRTS.Lang
13import IRTS.LangOpts
14import IRTS.Defunctionalise
15import IRTS.Simplified
16import IRTS.CodegenCommon
17import IRTS.CodegenC
18import IRTS.DumpBC
19import IRTS.CodegenJavaScript
20import IRTS.Inliner
21import IRTS.Exports
22import IRTS.Portable
24import Idris.AbsSyntax
25import Idris.AbsSyntaxTree
26import Idris.ASTUtils
27import Idris.Erasure
28import Idris.Error
29import Idris.Output
31import Debug.Trace
33import Idris.Core.TT
34import Idris.Core.Evaluate
35import Idris.Core.CaseTree
37import Control.Category
38import Prelude hiding (id, (.))
40import Control.Applicative
41import Control.Monad.State
43import Data.Maybe
44import Data.List
45import Data.Ord
46import Data.IntSet (IntSet)
47import qualified Data.IntSet as IS
48import qualified Data.Map as M
49import qualified Data.Set as S
51import System.Process
52import System.IO
53import System.Exit
54import System.Directory
55import System.Environment
56import System.FilePath ((</>), addTrailingPathSeparator)
58-- | Compile to simplified forms and return CodegenInfo
59compile :: Codegen -> FilePath -> Maybe Term -> Idris CodegenInfo
60compile codegen f mtm
61 = do checkMVs -- check for undefined metavariables
62 checkTotality -- refuse to compile if there are totality problems
63 exports <- findExports
64 let rootNames = case mtm of
65 Nothing -> []
66 Just t -> freeNames t
68 reachableNames <- performUsageAnalysis
69 (rootNames ++ getExpNames exports)
70 maindef <- case mtm of
71 Nothing -> return []
72 Just tm -> do md <- irMain tm
73 logCodeGen 1 $ "MAIN: " ++ show md
74 return [(sMN 0 "runMain", md)]
75 objs <- getObjectFiles codegen
76 libs <- getLibs codegen
77 flags <- getFlags codegen
78 hdrs <- getHdrs codegen
79 impdirs <- allImportDirs
80 defsIn <- mkDecls reachableNames
81 -- if no 'main term' given, generate interface files
82 let iface = case mtm of
83 Nothing -> True
84 Just _ -> False
86 let defs = defsIn ++ maindef
88 -- Inlined top level LDecl made here
89 let defsInlined = inlineAll defs
90 let defsUniq = map (allocUnique (addAlist defsInlined emptyContext))
91 defsInlined
93 let (nexttag, tagged) = addTags 65536 (liftAll defsUniq)
94 let ctxtIn = addAlist tagged emptyContext
96 logCodeGen 1 "Defunctionalising"
97 let defuns_in = defunctionalise nexttag ctxtIn
98 logCodeGen 5 $ show defuns_in
99 logCodeGen 1 "Inlining"
100 let defuns = inline defuns_in
101 logCodeGen 5 $ show defuns
102 logCodeGen 1 "Resolving variables for CG"
104 let checked = simplifyDefs defuns (toAlist defuns)
105 outty <- outputTy
106 dumpCases <- getDumpCases
107 dumpDefun <- getDumpDefun
108 case dumpCases of
109 Nothing -> return ()
110 Just f -> runIO $ writeFile f (showCaseTrees defs)
111 case dumpDefun of
112 Nothing -> return ()
113 Just f -> runIO $ writeFile f (dumpDefuns defuns)
114 triple <- Idris.AbsSyntax.targetTriple
115 cpu <- Idris.AbsSyntax.targetCPU
116 logCodeGen 1 "Building output"
117 case checked of
118 OK c -> do return $ CodegenInfo f outty triple cpu
119 hdrs impdirs objs libs flags
120 NONE c (toAlist defuns)
121 tagged iface exports
122 Error e -> ierror e
123 where checkMVs = do i <- getIState
124 case map fst (idris_metavars i) \\ primDefs of
125 [] -> return ()
126 ms -> do iputStrLn $ "WARNING: There are incomplete holes:\n " ++ show ms
127 iputStrLn "\nEvaluation of any of these will crash at run time."
128 return ()
129 checkTotality = do i <- getIState
130 case idris_totcheckfail i of
131 [] -> return ()
132 ((fc, msg):fs) -> ierror . At fc . Msg $ "Cannot compile:\n " ++ msg
134generate :: Codegen -> FilePath -> CodegenInfo -> IO ()
135generate codegen mainmod ir
136 = case codegen of
137 -- Built-in code generators (FIXME: lift these out!)
138 Via _ "c" -> codegenC ir
139 -- Any external code generator
140 Via fm cg -> do input <- case fm of
141 IBCFormat -> return mainmod
142 JSONFormat -> do
143 tempdir <- getTemporaryDirectory
144 (fn, h) <- openTempFile tempdir "idris-cg.json"
145 writePortable h ir
146 hClose h
147 return fn
148 let cmd = "idris-codegen-" ++ cg
149 args = [input, "-o", outputFile ir] ++ compilerFlags ir
150 exit <- rawSystem cmd args
151 when (exit /= ExitSuccess) $
152 putStrLn ("FAILURE: " ++ show cmd ++ " " ++ show args)
153 Bytecode -> dumpBC (simpleDecls ir) (outputFile ir)
155irMain :: TT Name -> Idris LDecl
156irMain tm = do
157 i <- irTerm M.empty [] tm
158 return $ LFun [] (sMN 0 "runMain") [] (LForce i)
160mkDecls :: [Name] -> Idris [(Name, LDecl)]
161mkDecls used
162 = do i <- getIState
163 let ds = filter (\(n, d) -> n `elem` used || isCon d) $ ctxtAlist (tt_ctxt i)
164 decls <- mapM build ds
165 return decls
167showCaseTrees :: [(Name, LDecl)] -> String
168showCaseTrees = showSep "\n\n" . map showCT . sortBy (comparing defnRank)
169 where
170 showCT (n, LFun _ f args lexp)
171 = show n ++ " " ++ showSep " " (map show args) ++ " =\n\t"
172 ++ show lexp
173 showCT (n, LConstructor c t a) = "data " ++ show n ++ " " ++ show a
175 defnRank :: (Name, LDecl) -> String
176 defnRank (n, LFun _ _ _ _) = "1" ++ nameRank n
177 defnRank (n, LConstructor _ _ _) = "2" ++ nameRank n
179 nameRank :: Name -> String
180 nameRank (UN s) = "1" ++ show s
181 nameRank (MN i s) = "2" ++ show s ++ show i
182 nameRank (NS n ns) = "3" ++ concatMap show (reverse ns) ++ nameRank n
183 nameRank (SN sn) = "4" ++ snRank sn
184 nameRank n = "5" ++ show n
186 snRank :: SpecialName -> String
187 snRank (WhereN i n n') = "1" ++ nameRank n' ++ nameRank n ++ show i
188 snRank (InstanceN n args) = "2" ++ nameRank n ++ concatMap show args
189 snRank (ParentN n s) = "3" ++ nameRank n ++ show s
190 snRank (MethodN n) = "4" ++ nameRank n
191 snRank (CaseN _ n) = "5" ++ nameRank n
192 snRank (ElimN n) = "6" ++ nameRank n
193 snRank (InstanceCtorN n) = "7" ++ nameRank n
194 snRank (WithN i n) = "8" ++ nameRank n ++ show i
196isCon (TyDecl _ _) = True
197isCon _ = False
199build :: (Name, Def) -> Idris (Name, LDecl)
200build (n, d)
201 = do i <- getIState
202 case getPrim n i of
203 Just (ar, op) ->
204 let args = map (\x -> sMN x "op") [0..] in
205 return (n, (LFun [] n (take ar args)
206 (LOp op (map (LV . Glob) (take ar args)))))
207 _ -> do def <- mkLDecl n d
208 logCodeGen 3 $ "Compiled " ++ show n ++ " =\n\t" ++ show def
209 return (n, def)
210 where getPrim n i
211 | Just (ar, op) <- lookup n (idris_scprims i)
212 = Just (ar, op)
213 | Just ar <- lookup n (S.toList (idris_externs i))
214 = Just (ar, LExternal n)
215 getPrim n i = Nothing
217declArgs args inl n (LLam xs x) = declArgs (args ++ xs) inl n x
218declArgs args inl n x = LFun (if inl then [Inline] else []) n args x
220mkLDecl n (Function tm _)
221 = declArgs [] True n <$> irTerm M.empty [] tm
223mkLDecl n (CaseOp ci _ _ _ pats cd)
224 = declArgs [] (case_inlinable ci || caseName n) n <$> irTree args sc
225 where
226 (args, sc) = cases_runtime cd
228 -- Always attempt to inline functions arising from 'case' expressions
229 caseName (SN (CaseN _ _)) = True
230 caseName (SN (WithN _ _)) = True
231 caseName (NS n _) = caseName n
232 caseName _ = False
234mkLDecl n (TyDecl (DCon tag arity _) _) =
235 LConstructor n tag . length <$> fgetState (cg_usedpos . ist_callgraph n)
237mkLDecl n (TyDecl (TCon t a) _) = return $ LConstructor n (-1) a
238mkLDecl n _ = return $ (declArgs [] True n LNothing) -- postulate, never run
240data VarInfo = VI
241 { viMethod :: Maybe Name
242 }
243 deriving Show
245type Vars = M.Map Name VarInfo
247irTerm :: Vars -> [Name] -> Term -> Idris LExp
248irTerm vs env tm@(App _ f a) = do
249 ist <- getIState
250 case unApply tm of
251 (P _ n _, args)
252 | n `elem` map fst (idris_metavars ist) \\ primDefs
253 -> return $ LError $ "ABORT: Attempt to evaluate hole " ++ show n
254 (P _ (UN m) _, args)
255 | m == txt "mkForeignPrim"
256 -> doForeign vs env (reverse (drop 4 args)) -- drop implicits
258 (P _ (UN u) _, [_, arg])
259 | u == txt "unsafePerformPrimIO"
260 -> irTerm vs env arg
262 -- TMP HACK - until we get inlining.
263 (P _ (UN r) _, [_, _, _, _, _, arg])
264 | r == txt "replace"
265 -> irTerm vs env arg
267 -- 'void' doesn't have any pattern clauses and only gets called on
268 -- erased things in higher order contexts (also a TMP HACK...)
269 (P _ (UN r) _, _)
270 | r == txt "void"
271 -> return LNothing
273 -- Laziness, the old way
274 (P _ (UN l) _, [_, arg])
275 | l == txt "lazy"
276 -> error "lazy has crept in somehow"
278 (P _ (UN l) _, [_, arg])
279 | l == txt "force"
280 -> LForce <$> irTerm vs env arg
282 -- Laziness, the new way
283 (P _ (UN l) _, [_, _, arg])
284 | l == txt "Delay"
285 -> LLazyExp <$> irTerm vs env arg
287 (P _ (UN l) _, [_, _, arg])
288 | l == txt "Force"
289 -> LForce <$> irTerm vs env arg
291 (P _ (UN a) _, [_, _, _, arg])
292 | a == txt "assert_smaller"
293 -> irTerm vs env arg
295 (P _ (UN a) _, [_, arg])
296 | a == txt "assert_total"
297 -> irTerm vs env arg
299 (P _ (UN p) _, [_, arg])
300 | p == txt "par"
301 -> do arg' <- irTerm vs env arg
302 return $ LOp LPar [LLazyExp arg']
304 (P _ (UN pf) _, [arg])
305 | pf == txt "prim_fork"
306 -> do arg' <- irTerm vs env arg
307 return $ LOp LFork [LLazyExp arg']
309 (P _ (UN m) _, [_,size,t])
310 | m == txt "malloc"
311 -> irTerm vs env t
313 (P _ (UN tm) _, [_,t])
314 | tm == txt "trace_malloc"
315 -> irTerm vs env t -- TODO
317 -- This case is here until we get more general inlining. It's just
318 -- a really common case, and the laziness hurts...
319 (P _ (NS (UN be) [b,p]) _, [_,x,(App _ (App _ (App _ (P _ (UN d) _) _) _) t),
320 (App _ (App _ (App _ (P _ (UN d') _) _) _) e)])
321 | be == txt "ifThenElse"
322 , d == txt "Delay"
323 , d' == txt "Delay"
324 , b == txt "Bool"
325 , p == txt "Prelude"
326 -> do
327 x' <- irTerm vs env x
328 t' <- irTerm vs env t
329 e' <- irTerm vs env e
330 return (LCase Shared x'
331 [LConCase 0 (sNS (sUN "False") ["Bool","Prelude"]) [] e'
332 ,LConCase 1 (sNS (sUN "True" ) ["Bool","Prelude"]) [] t'
333 ])
335 -- data constructor
336 (P (DCon t arity _) n _, args) -> do
337 detag <- fgetState (opt_detaggable . ist_optimisation n)
338 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)
340 let isNewtype = length used == 1 && detag
341 let argsPruned = [a | (i,a) <- zip [0..] args, i `elem` used]
343 -- The following code removes fields from data constructors
344 -- and performs the newtype optimisation.
345 --
346 -- The general rule here is:
347 -- Everything we get as input is not touched by erasure,
348 -- so it conforms to the official arities and types
349 -- and we can reason about it like it's plain TT.
350 --
351 -- It's only the data that leaves this point that's erased
352 -- and possibly no longer typed as the original TT version.
353 --
354 -- Especially, underapplied constructors must yield functions
355 -- even if all the remaining arguments are erased
356 -- (the resulting function *will* be applied, to NULLs).
357 --
358 -- This will probably need rethinking when we get erasure from functions.
360 -- "padLams" will wrap our term in LLam-bdas and give us
361 -- the "list of future unerased args" coming from these lambdas.
362 --
363 -- We can do whatever we like with the list of unerased args,
364 -- hence it takes a lambda: \unerased_argname_list -> resulting_LExp.
365 let padLams = padLambdas used (length args) arity
367 case compare (length args) arity of
369 -- overapplied
370 GT -> ifail ("overapplied data constructor: " ++ show tm ++
371 "\nDEBUG INFO:\n" ++
372 "Arity: " ++ show arity ++ "\n" ++
373 "Arguments: " ++ show args ++ "\n" ++
374 "Pruned arguments: " ++ show argsPruned)
376 -- exactly saturated
377 EQ | isNewtype
378 -> irTerm vs env (head argsPruned)
380 | otherwise -- not newtype, plain data ctor
381 -> buildApp (LV $ Glob n) argsPruned
383 -- not saturated, underapplied
384 LT | isNewtype -- newtype
385 , length argsPruned == 1 -- and we already have the value
386 -> padLams . (\tm [] -> tm) -- the [] asserts there are no unerased args
387 <$> irTerm vs env (head argsPruned)
389 | isNewtype -- newtype but the value is not among args yet
390 -> return . padLams $ \[vn] -> LApp False (LV $ Glob n) [LV $ Glob vn]
392 -- not a newtype, just apply to a constructor
393 | otherwise
394 -> padLams . applyToNames <$> buildApp (LV $ Glob n) argsPruned
396 -- type constructor
397 (P (TCon t a) n _, args) -> return LNothing
399 -- an external name applied to arguments
400 (P _ n _, args) | S.member (n, length args) (idris_externs ist) -> do
401 LOp (LExternal n) <$> mapM (irTerm vs env) args
403 -- a name applied to arguments
404 (P _ n _, args) -> do
405 case lookup n (idris_scprims ist) of
406 -- if it's a primitive that is already saturated,
407 -- compile to the corresponding op here already to save work
408 Just (arity, op) | length args == arity
409 -> LOp op <$> mapM (irTerm vs env) args
411 -- otherwise, just apply the name
412 _ -> applyName n ist args
414 -- turn de bruijn vars into regular named references and try again
415 (V i, args) -> irTerm vs env $ mkApp (P Bound (env !! i) Erased) args
417 (f, args)
418 -> LApp False
419 <$> irTerm vs env f
420 <*> mapM (irTerm vs env) args
422 where
423 buildApp :: LExp -> [Term] -> Idris LExp
424 buildApp e [] = return e
425 buildApp e xs = LApp False e <$> mapM (irTerm vs env) xs
427 applyToNames :: LExp -> [Name] -> LExp
428 applyToNames tm [] = tm
429 applyToNames tm ns = LApp False tm $ map (LV . Glob) ns
431 padLambdas :: [Int] -> Int -> Int -> ([Name] -> LExp) -> LExp
432 padLambdas used startIdx endSIdx mkTerm
433 = LLam allNames $ mkTerm nonerasedNames
434 where
435 allNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1]]
436 nonerasedNames = [sMN i "sat" | i <- [startIdx .. endSIdx-1], i `elem` used]
438 applyName :: Name -> IState -> [Term] -> Idris LExp
439 applyName n ist args =
440 LApp False (LV $ Glob n) <$> mapM (irTerm vs env . erase) (zip [0..] args)
441 where
442 erase (i, x)
443 | i >= arity || i `elem` used = x
444 | otherwise = Erased
446 arity = case fst4 <$> lookupCtxtExact n (definitions . tt_ctxt $ ist) of
447 Just (CaseOp ci ty tys def tot cdefs) -> length tys
448 Just (TyDecl (DCon tag ar _) _) -> ar
449 Just (TyDecl Ref ty) -> length $ getArgTys ty
450 Just (Operator ty ar op) -> ar
451 Just def -> error $ "unknown arity: " ++ show (n, def)
452 Nothing -> 0 -- no definition, probably local name => can't erase anything
454 -- name for purposes of usage info lookup
455 uName
456 | Just n' <- viMethod =<< M.lookup n vs = n'
457 | otherwise = n
459 used = maybe [] (map fst . usedpos) $ lookupCtxtExact uName (idris_callgraph ist)
460 fst4 (x,_,_,_,_) = x
462irTerm vs env (P _ n _) = return $ LV (Glob n)
463irTerm vs env (V i)
464 | i >= 0 && i < length env = return $ LV (Glob (env!!i))
465 | otherwise = ifail $ "bad de bruijn index: " ++ show i
467irTerm vs env (Bind n (Lam _) sc) = LLam [n'] <$> irTerm vs (n':env) sc
468 where
469 n' = uniqueName n env
471irTerm vs env (Bind n (Let _ v) sc)
472 = LLet n <$> irTerm vs env v <*> irTerm vs (n : env) sc
474irTerm vs env (Bind _ _ _) = return $ LNothing
476irTerm vs env (Proj t (-1)) = do
477 t' <- irTerm vs env t
478 return $ LOp (LMinus (ATInt ITBig))
479 [t', LConst (BI 1)]
481irTerm vs env (Proj t i) = LProj <$> irTerm vs env t <*> pure i
482irTerm vs env (Constant TheWorld) = return $ LNothing
483irTerm vs env (Constant c) = return $ LConst c
484irTerm vs env (TType _) = return $ LNothing
485irTerm vs env Erased = return $ LNothing
486irTerm vs env Impossible = return $ LNothing
488doForeign :: Vars -> [Name] -> [Term] -> Idris LExp
489doForeign vs env (ret : fname : world : args)
490 = do args' <- mapM splitArg args
491 let fname' = toFDesc fname
492 let ret' = toFDesc ret
493 return $ LForeign ret' fname' args'
494 where
495 splitArg tm | (_, [_,_,l,r]) <- unApply tm -- pair, two implicits
496 = do let l' = toFDesc l
497 r' <- irTerm vs env r
498 return (l', r')
499 splitArg _ = ifail $ "Badly formed foreign function call"
501 toFDesc (Constant (Str str)) = FStr str
502 toFDesc tm
503 | (P _ n _, []) <- unApply tm = FCon (deNS n)
504 | (P _ n _, as) <- unApply tm = FApp (deNS n) (map toFDesc as)
505 toFDesc _ = FUnknown
507 deNS (NS n _) = n
508 deNS n = n
509doForeign vs env xs = ifail "Badly formed foreign function call"
511irTree :: [Name] -> SC -> Idris LExp
512irTree args tree = do
513 logCodeGen 3 $ "Compiling " ++ show args ++ "\n" ++ show tree
514 LLam args <$> irSC M.empty tree
516irSC :: Vars -> SC -> Idris LExp
517irSC vs (STerm t) = irTerm vs [] t
518irSC vs (UnmatchedCase str) = return $ LError str
520irSC vs (ProjCase tm alts) = do
521 tm' <- irTerm vs [] tm
522 alts' <- mapM (irAlt vs tm') alts
523 return $ LCase Shared tm' alts'
525-- Transform matching on Delay to applications of Force.
526irSC vs (Case up n [ConCase (UN delay) i [_, _, n'] sc])
527 | delay == txt "Delay"
528 = do sc' <- irSC vs $ mkForce n' n sc
529 return $ LLet n' (LForce (LV (Glob n))) sc'
531-- There are two transformations in this case:
532--
533-- 1. Newtype-case elimination:
534-- case {e0} of
535-- wrap({e1}) -> P({e1}) ==> P({e0})
536--
537-- This is important because newtyped constructors are compiled away entirely
538-- and we need to do that everywhere.
539--
540-- 2. Unused-case elimination (only valid for singleton branches):
541-- case {e0} of ==> P
542-- C(x,y) -> P[... x,y not used ...]
543--
544-- This is important for runtime because sometimes we case on irrelevant data:
545--
546-- In the example above, {e0} will most probably have been erased
547-- so this vain projection would make the resulting program segfault
548-- because the code generator still emits a PROJECT(...) G-machine instruction.
549--
550-- Hence, we check whether the variables are used at all
551-- and erase the casesplit if they are not.
552--
553irSC vs (Case up n [alt]) = do
554 replacement <- case alt of
555 ConCase cn a ns sc -> do
556 detag <- fgetState (opt_detaggable . ist_optimisation cn)
557 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph cn)
558 if detag && length used == 1
559 then return . Just $ substSC (ns !! head used) n sc
560 else return Nothing
561 _ -> return Nothing
563 case replacement of
564 Just sc -> irSC vs sc
565 _ -> do
566 alt' <- irAlt vs (LV (Glob n)) alt
567 return $ case namesBoundIn alt' `usedIn` subexpr alt' of
568 [] -> subexpr alt' -- strip the unused top-most case
569 _ -> LCase up (LV (Glob n)) [alt']
570 where
571 namesBoundIn :: LAlt -> [Name]
572 namesBoundIn (LConCase cn i ns sc) = ns
573 namesBoundIn (LConstCase c sc) = []
574 namesBoundIn (LDefaultCase sc) = []
576 subexpr :: LAlt -> LExp
577 subexpr (LConCase _ _ _ e) = e
578 subexpr (LConstCase _ e) = e
579 subexpr (LDefaultCase e) = e
581-- FIXME: When we have a non-singleton case-tree of the form
582--
583-- case {e0} of
584-- C(x) => ...
585-- ... => ...
586--
587-- and C is detaggable (the only constructor of the family), we can be sure
588-- that the first branch will be always taken -- so we add special handling
589-- to remove the dead default branch.
590--
591-- If we don't do so and C is newtype-optimisable, we will miss this newtype
592-- transformation and the resulting code will probably segfault.
593--
594-- This work-around is not entirely optimal; the best approach would be
595-- to ensure that such case trees don't arise in the first place.
596--
597irSC vs (Case up n alts@[ConCase cn a ns sc, DefaultCase sc']) = do
598 detag <- fgetState (opt_detaggable . ist_optimisation cn)
599 if detag
600 then irSC vs (Case up n [ConCase cn a ns sc])
601 else LCase up (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts
603irSC vs sc@(Case up n alts) = do
604 -- check that neither alternative needs the newtype optimisation,
605 -- see comment above
606 goneWrong <- or <$> mapM isDetaggable alts
607 when goneWrong
608 $ ifail ("irSC: non-trivial case-match on detaggable data: " ++ show sc)
610 -- everything okay
611 LCase up (LV (Glob n)) <$> mapM (irAlt vs (LV (Glob n))) alts
612 where
613 isDetaggable (ConCase cn _ _ _) = fgetState $ opt_detaggable . ist_optimisation cn
614 isDetaggable _ = return False
616irSC vs ImpossibleCase = return LNothing
618irAlt :: Vars -> LExp -> CaseAlt -> Idris LAlt
620-- this leaves out all unused arguments of the constructor
621irAlt vs _ (ConCase n t args sc) = do
622 used <- map fst <$> fgetState (cg_usedpos . ist_callgraph n)
623 let usedArgs = [a | (i,a) <- zip [0..] args, i `elem` used]
624 LConCase (-1) n usedArgs <$> irSC (methodVars `M.union` vs) sc
625 where
626 methodVars = case n of
627 SN (InstanceCtorN className)
628 -> M.fromList [(v, VI
629 { viMethod = Just $ mkFieldName n i
630 }) | (v,i) <- zip args [0..]]
631 _
632 -> M.empty -- not an instance constructor
634irAlt vs _ (ConstCase x rhs)
635 | matchable x = LConstCase x <$> irSC vs rhs
636 | matchableTy x = LDefaultCase <$> irSC vs rhs
637 where
638 matchable (I _) = True
639 matchable (BI _) = True
640 matchable (Ch _) = True
641 matchable (Str _) = True
642 matchable (B8 _) = True
643 matchable (B16 _) = True
644 matchable (B32 _) = True
645 matchable (B64 _) = True
646 matchable _ = False
648 matchableTy (AType (ATInt ITNative)) = True
649 matchableTy (AType (ATInt ITBig)) = True
650 matchableTy (AType (ATInt ITChar)) = True
651 matchableTy StrType = True
653 matchableTy (AType (ATInt (ITFixed IT8))) = True
654 matchableTy (AType (ATInt (ITFixed IT16))) = True
655 matchableTy (AType (ATInt (ITFixed IT32))) = True
656 matchableTy (AType (ATInt (ITFixed IT64))) = True
658 matchableTy _ = False
660irAlt vs tm (SucCase n rhs) = do
661 rhs' <- irSC vs rhs
662 return $ LDefaultCase (LLet n (LOp (LMinus (ATInt ITBig))
663 [tm,
664 LConst (BI 1)]) rhs')
666irAlt vs _ (ConstCase c rhs)
667 = ifail $ "Can't match on (" ++ show c ++ ")"
669irAlt vs _ (DefaultCase rhs)
670 = LDefaultCase <$> irSC vs rhs