Wrinkles

 (W2) We need two absent-error Ids, aBSENT_ERROR_ID for types of kind Type, and

      aBSENT_CONSTRAINT_ERROR_ID for types of kind Constraint.

      of type TYPE rr. See (CPR2) in Note [Which types are unboxed?] in

      GHC.Core.Opt.WorkWrap.Utils.

 Type and Constraint are not equal (eqType) but they are not /apart/

 either. Reason (c.f. #7451):

      So in GHC.Tc.Instance.Class.matchTypeable, Type and Constraint are

      treated as separate TyCons; i.e. given no special treatment.

 Note [RuntimeRep polymorphism]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

 Generally speaking, you can't be polymorphic in `RuntimeRep`.  E.g

 -- | Given a coercion `co :: (t1 :: TYPE r1) ~ (t2 :: TYPE r2)`

 -- produce a coercion `rep_co :: r1 ~ r2`

 mkRuntimeRepCo :: HasDebugCallStack => Coercion -> Coercion

 mkRuntimeRepCo co

   = assert (isTYPEorCONSTRAINT k1 && isTYPEorCONSTRAINT k2) $

     kind_co = mkKindCo co  -- kind_co :: TYPE r1 ~ TYPE r2

     Pair k1 k2 = coercionKind kind_co

 isReflCoVar_maybe :: Var -> Maybe Coercion

 -- If cv :: t~t then isReflCoVar_maybe cv = Just (Refl t)

 -- Works on all kinds of Vars, not just CoVars

        , Just (tc2, tys2) <- splitTyConApp_maybe ty2

        , let { len1 = length tys1

              ; len2 = length tys2 }

        && len1 == len2

        && n < len1

        && r == tyConRole (coercionRole co) tc1 n

          hang (text "Inhomogeneous axiom")

             2 (text "lhs:" <+> ppr lhs <+> dcolon <+> ppr lhs_kind $$

                text "rhs:" <+> ppr rhs <+> dcolon <+> ppr rhs_kind) }

 lint_family_branch :: TyCon -> CoAxBranch -> LintM ()

 lint_family_branch fam_tc br@(CoAxBranch { cab_tvs     = tvs

                                          , cab_eta_tvs = eta_tvs

                                          , cab_cvs     = cvs

 import GHC.Utils.Outputable

 import GHC.Types.Name

 import GHC.Types.Name.Env

 import Control.Monad (join)

 import Data.Data (Data)

 roughMatchTyConName :: TyCon -> Name

 roughMatchTyConName tc

 -- | Trie of @[RoughMatchTc]@

 --

                       Nothing  -> pprPanic "piResultTy" (ppr ty $$ ppr arg)

 piResultTy_maybe :: Type -> Type -> Maybe Type

 piResultTy_maybe ty arg = case coreFullView ty of

   FunTy { ft_res = res } -> Just res

 import GHC.Types.Var

 import GHC.Types.Var.Env

 import GHC.Types.Var.Set

 import GHC.Core.Type     hiding ( getTvSubstEnv )

 import GHC.Core.Coercion hiding ( getCvSubstEnv )

 import GHC.Core.Predicate( scopedSort )

          See Note [Apartness and type families]

     * MARInfinite (occurs check):

          See Note [Infinitary substitutions]

     * MARCast (obscure):

          See (KCU2) in Note [Kind coercions in Unify]

 -- | Why are two types 'MaybeApart'? 'MARInfinite' takes precedence:

 -- This is used (only) in Note [Infinitary substitution in lookup] in GHC.Core.InstEnv

 data MaybeApartReason

   = MARTypeFamily   -- ^ matching e.g. F Int ~? Bool

   | MARInfinite     -- ^ matching e.g. a ~? Maybe a

   | MARCast         -- ^ Very obscure.

     -- See (KCU2) in Note [Kind coercions in Unify]

 -- See (UR1) in Note [Unification result] for why MARInfinite wins

 combineMAR MARInfinite         _ = MARInfinite   -- MARInfinite wins

 combineMAR MARTypeFamily       r = r             -- Otherwise it doesn't really matter

 combineMAR MARCast             r = r

 instance Outputable MaybeApartReason where

   ppr MARTypeFamily       = text "MARTypeFamily"

   ppr MARInfinite         = text "MARInfinite"

   ppr MARCast             = text "MARCast"

 instance Semigroup MaybeApartReason where

        ; unify_tc_app env tc1 tys1 tys2

        }

   where

     mb_tc_app1 = splitTyConApp_maybe ty1

     mb_tc_app2 = splitTyConApp_maybe ty2

 import qualified Data.Set as Set

 import GHC.Iface.Errors.Types

 import Data.Either

 -----------------------------------------------------------------

 --

               obj_file  = msObjFilePath node

               obj_files = insertSuffixes obj_file extra_suffixes

                 -- Emit std dependency of the object(s) on the source file

                 -- Emit a dependency for each import

                     | (_lvl, mb_pkg, L loc mod) <- idecls,

                       mod `notElem` excl_mods ]

 findDependency  :: HscEnv

                 -> SrcSpan

                 -> ModuleName           -- Imported module

                 -> IsBootInterface      -- Source import

                 -> Bool                 -- Record dependency on package modules

 findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps = do

   -- Find the module; this will be fast because

   -- we've done it once during downsweep

     Found loc _

         -- Home package: just depend on the .hi or hi-boot file

         | isJust (ml_hs_file loc) || include_pkg_deps

         -- Not in this package: we don't need a dependency

         | otherwise

     fail ->

           mkPlainErrorMsgEnvelope srcloc $

           GhcDriverMessage $ DriverInterfaceError $

              (Can'tFindInterface (cannotFindModule hsc_env imp fail) (LookingForModule imp is_boot))

       as'      <- concatMapM genArg args

       ei       <- varForEntryId i

       let ra = mconcat . reverse $

       p <- pushLneFrame n ctx

       a <- adjSp 1 -- for the header (which will only be written when the thread is suspended)

       return (ra <> p <> a <> returnS ei, ExprCont)

 specTagExpr :: ApplySpec -> JStgExpr

 specTagExpr = toJExpr . specTag

 --

 mkApplyArr :: JSM JStgStat

 mkApplyArr =

      return $ mconcat

        ]

   where

       -- both fast/slow (regs/stack) specialized apply functions have the same

       -- tags. We store the stack ones in the array because they are used as

       -- continuation stack frames.

     hdPap_ = unpackFS hdPapStr_

 -- | Push a continuation on the stack

 --

                          -- compute new tag with consumed register values and args removed

                          , newTag |= ((given_regs-needed_regs).<<.8) .|. (given_args - needed_args)

                          -- find application function for the remaining regs/args

                          , traceRts cfg (jString "h$ap_gen: next: " + (newAp .^ "n"))

                          -- Drop used registers from the stack.

                          -----------------------------

                          [ traceRts cfg (jString "h$ap_gen: undersat")

                          -- find PAP entry function corresponding to given_regs count

                          -- build PAP payload: R1 + tag + given register values

                          , newTag |= ((needed_regs-given_regs) .<<. 8) .|. (needed_args-given_args)

              do push_all_regs <- pushAllRegs tag

                 return $ mconcat $

                   [ push_all_regs

                   , ifS (ap .===. hdApGen)

                     ((sp |= sp + 2) <> (stack .! (sp-1) |= tag))

                     (sp |= sp + 1)

                 , traceRts s (jString "h$ap_gen_fast: oversat " + sp)

                 , push_args

                 , newTag |= ((myRegs-( arity.>>.8)).<<.8).|.myAr-ar

                 , ifS (newAp .===. hdApGen)

                   ((sp |= sp + 2) <> (stack .! (sp - 1) |= newTag))

                   (sp |= sp + 1)

                -- else

                 [traceRts s (jString "h$ap_gen_fast: undersat: " + myRegs + jString " " + tag)

                 , jwhenS (tag .!=. 0) $ mconcat

                   , dat |= toJExpr [r1, ((arity .>>. 8)-myRegs)*256+ar-myAr]

                   , get_regs

                   , r1 |= initClosure s p dat jCurrentCCS

     pushAllRegs :: JStgExpr -> JSM JStgStat

     pushAllRegs tag =

       jVar \regs ->

     pushArgs :: JStgExpr -> JStgExpr -> JSM JStgStat

     pushArgs start end =

              [ rs |= (arity .>>. 8)

              , loadRegs rs

              , sp |= sp - rs

              , stack .! sp |= newAp

              , profStat s pushRestoreCCS

              , traceRts s (toJExpr (fun_name <> ": new stack frame: ") + (newAp .^ "n"))

                               + rsRemain)

                 , saveRegs rs

                 , sp |= sp + rsRemain + 1

                 , profStat s pushRestoreCCS

                 , returnS c

                 ]

              , profStat s (enterCostCentreFun currentCCS)

              , extra |= (funOrPapArity c (Just f) .>>. 8) - toJExpr r

              , traceRts s (toJExpr (funcName <> ": pap extra args moving: ") + extra)

              , loadOwnArgs d

              , r1 |= c

              , returnS f

              ]

     loadOwnArgs d = mconcat $ map (\r ->

         jsReg (r+1) |= dField d (r+2)) [1..r]

     dField d n = SelExpr d (name . mkFastString $ ('d':show (n-1)))

                 (jString "h$pap_gen: expected function or pap")

               , profStat cfg (enterCostCentreFun currentCCS)

               , traceRts cfg (jString "h$pap_gen: generic pap extra args moving: " + or)

               , appS hdMoveRegs2 [or, r]

               , loadOwnArgs d r

               , r1 |= c

               , returnS f

     funcIdent = name funcName

     funcName = hdPapGenStr

     loadOwnArgs d r =

 -- general utilities

 -- move the first n registers, starting at R2, m places up (do not use with negative m)

     switchCase n m = (toJExpr $

                       (n `Bits.shiftL` 8) Bits..|. m

                      , mconcat (map (`moveRegFast` m) [n+1,n..2])

     moveRegFast n m = jsReg (n+m) |= jsReg n

     -- fallback

     defaultCase n m =

   -- load arguments into local variables

   la <- do

     args' <- concatMapM genIdArgI args

   -- assert that arguments have valid runtime reps

   lav <- verifyRuntimeReps args

   | otherwise = do

       rj       <- genRet ctx bnd at alts l

       let ctx' = ctxSetTop bnd

                   $ ctx

       (ej, _r) <- genExpr ctx' e

       return (rj <> ej, ExprCont)

     fun free = resetSlots $ do

       decs          <- declVarsForId e

       loadv         <- verifyRuntimeReps [e]

       ras           <- loadRetArgs free

       rasv          <- verifyRuntimeReps (map (\(x,_,_)->x) free)

 {-# LANGUAGE OverloadedStrings #-}

 module GHC.StgToJS.Regs

   ( StgReg (..)

   , sp

   , stack

   , r1, r2, r3, r4

   , regsFromR1

   , regsFromR2

   , jsRegsFromR1

   , jsRegsFromR2

   , StgRet (..)

   , jsReg

   , maxReg

   , minReg

   , lowRegs

   , retRegs

   , register

   , foreignRegister

 import GHC.StgToJS.Symbols

 import GHC.Data.FastString

 import Data.Array

 import qualified Data.ByteString.Char8 as BSC

 import Data.Semigroup ((<>))

 -- | General purpose "registers"

 -- | Stack registers

 data Special

   toJExpr Sp     = hdStackPtr

 instance ToJExpr StgReg where

 instance ToJExpr StgRet where

   toJExpr r = rets ! r

 r3 = toJExpr R3

 r4 = toJExpr R4

 jsReg :: Int -> JStgExpr

 -- | List of registers, starting from R1

 regsFromR1 :: [StgReg]

 -- | List of registers, starting from R2

 regsFromR2 :: [StgReg]

 jsRegsFromR2 :: [JStgExpr]

 jsRegsFromR2 = tail jsRegsFromR1